From 710f053fbd7c65a3e8cfa051f8a2fdb92ebeeec8 Mon Sep 17 00:00:00 2001 From: sf-mensch Date: Wed, 2 Oct 2024 22:26:37 +0000 Subject: [PATCH 01/29] testsuite update for special cases tests: atlocal.in, atlocal_win: allow overriding COB_CC during tests --- tests/ChangeLog | 4 ++++ tests/atlocal.in | 11 +++++++++-- tests/atlocal_win | 14 ++++++++++---- 3 files changed, 23 insertions(+), 6 deletions(-) diff --git a/tests/ChangeLog b/tests/ChangeLog index a15ae66df..b99d0ba74 100644 --- a/tests/ChangeLog +++ b/tests/ChangeLog @@ -1,4 +1,8 @@ +2024-10-02 Simon Sobisch + + * atlocal.in, atlocal_win: allow overriding COB_CC during tests + 2024-09-09 Simon Sobisch * run_prog_manual.sh.in: adding testrunner tmux as alternative diff --git a/tests/atlocal.in b/tests/atlocal.in index 68cb4ba1c..d2f0a4429 100644 --- a/tests/atlocal.in +++ b/tests/atlocal.in @@ -185,6 +185,7 @@ _unset_option () { -a "$1" != "COB_COPY_DIR" \ -a "$1" != "COB_RUNTIME_CONFIG" \ -a "$1" != "COB_LIBRARY_PATH" \ + -a "$1" != "COB_CC" \ -a "$1" != "COB_CFLAGS" \ -a "$1" != "COB_LIBS" \ -a "$1" != "COB_UNIX_LF" \ @@ -295,8 +296,11 @@ COB_STACKTRACE=0 export COB_STACKTRACE -# different flags checked in the testsuite +# different variables used in the testsuite if test "$GNUCOBOL_TEST_LOCAL" != "1"; then + if test "$COB_CC" = ""; then + COB_CC="@COB_CC@" + fi COB_OBJECT_EXT="@COB_OBJECT_EXT@" COB_EXE_EXT="@COB_EXE_EXT@" COB_MODULE_EXT="@COB_MODULE_EXT@" @@ -308,6 +312,9 @@ if test "$GNUCOBOL_TEST_LOCAL" != "1"; then COB_HAS_CURSES="@COB_HAS_CURSES@" else + if test "$COB_CC" = ""; then + COB_CC="$($GREP COBC_CC info.out | cut -d: -f2 | cut -b2-)" + fi COB_OBJECT_EXT="$($GREP COB_OBJECT_EXT info.out | cut -d: -f2 | cut -b2-)" COB_EXE_EXT="$($GREP COB_EXE_EXT info.out | cut -d: -f2 | cut -b2-)" COB_MODULE_EXT="$($GREP COB_MODULE_EXT info.out | cut -d: -f2 | cut -b2-)" @@ -379,7 +386,7 @@ rm -rf info.out # NIST tests (tests/cobol85) are executed in a separate perl process with a new environment --> export needed export COB_HAS_ISAM COB_HAS_XML2 COB_HAS_JSON COB_HAS_CURSES COB_HAS_64_BIT_POINTER export COBC COBCRUN COBCRUN_DIRECT RUN_PROG_MANUAL -export COB_OBJECT_EXT COB_EXE_EXT COB_MODULE_EXT +export COB_CC COB_OBJECT_EXT COB_EXE_EXT COB_MODULE_EXT # to ensure that no external DB_HOME is polluted: unset DB_HOME="" && export DB_HOME diff --git a/tests/atlocal_win b/tests/atlocal_win index b6dec388f..8cf1e85cf 100644 --- a/tests/atlocal_win +++ b/tests/atlocal_win @@ -27,7 +27,10 @@ TEMPLATE="${abs_srcdir}/testsuite.src" COB_SRC_PATH="$(cd ${abs_srcdir}/.. ; pwd)" -COB_WIN_BUILDPATH="$COB_SRC_PATH/build_windows/x64/Debug" + +if test "${COB_WIN_BUILDPATH}" = ""; then + COB_WIN_BUILDPATH="$COB_SRC_PATH/build_windows/x64/Debug" +fi COBC="cobc.exe" COBCRUN="cobcrun.exe" @@ -74,6 +77,7 @@ _unset_option () { -a "$1" != "COB_COPY_DIR" \ -a "$1" != "COB_RUNTIME_CONFIG" \ -a "$1" != "COB_LIBRARY_PATH" \ + -a "$1" != "COB_CC" \ -a "$1" != "COB_CFLAGS" \ -a "$1" != "COB_LIBS" \ -a "$1" != "COB_UNIX_LF" \ @@ -164,9 +168,11 @@ export COB_STACKTRACE COB_MSG_FORMAT=GCC export COB_MSG_FORMAT -# different flags checked in the testsuite +# different variables used in the testsuite # note: kept intended to ease merge from atlocal.in - + if test "$COB_CC" = ""; then + COB_CC="$($GREP COBC_CC info.out | cut -d: -f2 | cut -b2-)" + fi COB_OBJECT_EXT="$($GREP COB_OBJECT_EXT info.out | cut -d: -f2 | cut -b2-)" COB_EXE_EXT=".exe" COB_MODULE_EXT="dll" @@ -238,7 +244,7 @@ rm -rf info.out # NIST tests (tests/cobol85) are executed in a separate perl process with a new environment --> export needed export COB_HAS_ISAM COB_HAS_XML2 COB_HAS_JSON COB_HAS_CURSES COB_HAS_64_BIT_POINTER export COBC COBCRUN COBCRUN_DIRECT RUN_PROG_MANUAL -export COB_OBJECT_EXT COB_EXE_EXT COB_MODULE_EXT +export COB_CC COB_OBJECT_EXT COB_EXE_EXT COB_MODULE_EXT # to ensure that no external DB_HOME is polluted: unset DB_HOME="" && export DB_HOME From 3f7c44b6f51605eda7da480388f8ae2efdd92811 Mon Sep 17 00:00:00 2001 From: sf-mensch Date: Wed, 2 Oct 2024 22:31:52 +0000 Subject: [PATCH 02/29] improve stdin compilation cobc: * pplex.l (output_line_directive): extracted from other places and extended to output compile from stdin as * codegen.c (output_cobol_info): output compile from stdin as --- cobc/ChangeLog | 6 ++++++ cobc/codegen.c | 19 ++++++++++++++----- cobc/pplex.l | 17 ++++++++++++++--- tests/testsuite.src/used_binaries.at | 4 ++++ 4 files changed, 38 insertions(+), 8 deletions(-) diff --git a/cobc/ChangeLog b/cobc/ChangeLog index 3d38e0246..58895a50a 100644 --- a/cobc/ChangeLog +++ b/cobc/ChangeLog @@ -1,4 +1,10 @@ +2024-10-02 Simon Sobisch + + * pplex.l (output_line_directive): extracted from other places and + extended to output compile from stdin as + * codegen.c (output_cobol_info): output compile from stdin as + 2024-10-01 Nicolas Berthier * tree.c (validate_indexed_key_field): warn about ignored collating diff --git a/cobc/codegen.c b/cobc/codegen.c index d3bcc2fc7..c46d67f24 100644 --- a/cobc/codegen.c +++ b/cobc/codegen.c @@ -5354,7 +5354,11 @@ output_initialize_to_default (struct cb_field *f, cb_tree x) static void output_c_info (void) { - /* note: output name is already escaped for C string */ + /* note: output name is already escaped for C string; + output name cannot be COB_DASH as we generate the headers "on the fly" and + would have to place everything into temporary files (which would have a name) + and after we're finished cat those to stdout; or adjust to first generate the + headers (in memory) and output them instead of the #include */ output ("#line %d \"%s\"", output_line_number + 1, output_name); output_newline (); } @@ -5364,12 +5368,17 @@ output_cobol_info (cb_tree x) { const char *p = x->source_file; output ("#line %d \"", x->source_line); + + if (strcmp (p, COB_DASH)) { /* escape COBOL file name for C string */ - while (*p) { - if (*p == '\\') { - output ("%c",'\\'); + while (*p) { + if (*p == '\\') { + output ("%c", '\\'); + } + output ("%c", *p++); } - output ("%c",*p++); + } else { + output (""); } output ("\""); output_newline (); diff --git a/cobc/pplex.l b/cobc/pplex.l index c3bbafbc9..303f34ec3 100644 --- a/cobc/pplex.l +++ b/cobc/pplex.l @@ -1616,6 +1616,16 @@ cb_copy_find_file (char *name, int has_ext) return NULL; } +static COB_INLINE COB_A_INLINE void +output_line_directive (FILE *stream) +{ + if (strcmp (cb_source_file, COB_DASH)) { + fprintf (yyout, "#line %d \"%s\"\n", cb_source_line, cb_source_file); + } else { + fprintf (yyout, "#line %d \"\"\n", cb_source_line); + } +} + static COB_INLINE COB_A_INLINE void output_pending_newlines (FILE *stream) { @@ -1624,7 +1634,7 @@ output_pending_newlines (FILE *stream) long comment blocks, for example from EXEC SQL preparsers), so generate source directive from the already adjusted static vars instead of spitting out possibly hundreds of empty lines */ - fprintf (stream, "\n#line %d \"%s\"\n", cb_source_line, cb_source_file); + output_line_directive (stream); echo_newline = 0; } else { while (echo_newline > 1) { @@ -1756,7 +1766,7 @@ ppcopy (const char *name, const char *lib, struct cb_replace_list *replace_list) /* On COPY, open error restore old file */ cb_current_file = old_list_file; - fprintf (yyout, "#line %d \"%s\"\n", cb_source_line, cb_source_file); + output_line_directive (yyout); return -1; } @@ -2120,7 +2130,8 @@ switch_to_buffer (const int line, const char *file, const YY_BUFFER_STATE buffer /* Reset file/line */ cb_source_line = line; cb_source_file = file; - fprintf (yyout, "#line %d \"%s\"\n", line, file); + + output_line_directive (yyout); /* Switch buffer */ yy_switch_to_buffer (buffer); } diff --git a/tests/testsuite.src/used_binaries.at b/tests/testsuite.src/used_binaries.at index 5a4ddf77f..4dabfc80c 100644 --- a/tests/testsuite.src/used_binaries.at +++ b/tests/testsuite.src/used_binaries.at @@ -948,6 +948,10 @@ AT_CHECK([cat prog.cob | $COMPILE -], [0], [], [], ) AT_CHECK([$COBCRUN_DIRECT ./a.out], [0], [], []) +AT_CHECK([echo "program-id.test." | $COMPILE_MODULE -free -E -], [0], +[#line 1 "" +program-id.test. +], []) AT_CLEANUP From 88937849b8607f9f9b20a605d7f2bf65e9ed7427 Mon Sep 17 00:00:00 2001 From: sf-mensch Date: Wed, 2 Oct 2024 23:08:13 +0000 Subject: [PATCH 03/29] new options for configure for customized version string / bug report URL * configure.ac, NEWS: adjusted * bin/cobcrun: * (cobcrun_print_version): build and package data only shown in verbose mode; PACKAGE_NAME may now be overwritten by PKGVERSION (new configure option) * (cobcrun_print_usage): handle PACKAGE_BUGREPORT_URL as alternative to mailing list, now resolved by PACKAGE_BUGREPORT * cobc: * cobc.c (cobc_print_version, cobc_print_shortversion, process_command_line): build and package data only shown in verbose mode which does not output the verbose "process" calls by default; PACKAGE_NAME may now be overwritten by PKGVERSION (new configure option) * help.c (cobc_print_usage): handle PACKAGE_BUGREPORT_URL as alternative to mailing list, now resolved by PACKAGE_BUGREPORT * libcob/common.c (print_version): PACKAGE_NAME may now be overwritten by PKGVERSION (new configure option) --- ChangeLog | 5 ++++ NEWS | 7 +++++ bin/ChangeLog | 10 ++++++- bin/cobcrun.c | 78 ++++++++++++++++++++++++++++-------------------- cobc/ChangeLog | 24 +++++++++------ cobc/cobc.c | 31 ++++++++++++------- cobc/help.c | 14 ++++++--- configure.ac | 46 ++++++++++++++++++++++++++++ libcob/ChangeLog | 5 ++++ libcob/common.c | 13 ++++---- 10 files changed, 170 insertions(+), 63 deletions(-) diff --git a/ChangeLog b/ChangeLog index ab1e792a6..d790fe60a 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,4 +1,9 @@ +2024-10-02 Simon Sobisch + + * configure.ac: new options --with-pkgversion=PKG and --with-bugurl=URL + see NEWS, currently only used in version and help output + 2024-09-29 Simon Sobisch * configure.ac: drop COB_LI_IS_LL in favor of existing COB_32_BIT_LONG diff --git a/NEWS b/NEWS index c87619496..306f35115 100644 --- a/NEWS +++ b/NEWS @@ -94,6 +94,13 @@ NEWS - user visible changes -*- outline -*- this is used for character encoding support, which otherwise is only provided partially +** configure now accepts --with-bugurl=URL which can be used to output a link + to an external or local URL (like file://) instead of the bug mailing list + +** configure now accepts --with-pkgversion=PKG which can be used to customize + the version output with a free-standing string (like revision number or + package manager version) + ** use the "default" -shared flag to build dynamic libraries on macOS so as to fix testuite issues with recent macOS versions diff --git a/bin/ChangeLog b/bin/ChangeLog index 69bc366d7..8f456551a 100644 --- a/bin/ChangeLog +++ b/bin/ChangeLog @@ -1,4 +1,12 @@ +2024-10-02 Simon Sobisch + + * cobcrun.c (cobcrun_print_version): build and package data only + shown in verbose mode; + PACKAGE_NAME may now be overwritten by PKGVERSION (new configure option) + * cobcrun.c (cobcrun_print_usage): handle PACKAGE_BUGREPORT_URL as + alternative to mailing list, now resolved by PACKAGE_BUGREPORT + 2023-07-24 Simon Sobisch * cob-config.in: prevent warning to use datadir, but not datarootdir; @@ -291,7 +299,7 @@ then you can switch easily. -Copyright 2004-2008,2010,2012,2014-2023 Free Software Foundation, Inc. +Copyright 2004-2008,2010,2012,2014-2024 Free Software Foundation, Inc. Copying and distribution of this file, with or without modification, are permitted provided the copyright notice and this notice are preserved. diff --git a/bin/cobcrun.c b/bin/cobcrun.c index cf4992f57..386ffd800 100644 --- a/bin/cobcrun.c +++ b/bin/cobcrun.c @@ -1,5 +1,5 @@ /* - Copyright (C) 2004-2012, 2014-2023 Free Software Foundation, Inc. + Copyright (C) 2004-2012, 2014-2024 Free Software Foundation, Inc. Written by Roger While, Simon Sobisch, Brian Tiffin This file is part of GnuCOBOL. @@ -70,43 +70,47 @@ static const struct option long_options[] = { /** - * Display cobcrun build and version date + * Display cobcrun version info, optional with build and version date */ static void cobcrun_print_version (void) { - char cob_build_stamp[COB_MINI_BUFF]; - char month[64]; - int status, day, year; - - /* Set up build time stamp */ - memset (cob_build_stamp, 0, (size_t)COB_MINI_BUFF); - memset (month, 0, sizeof(month)); - day = 0; - year = 0; - status = sscanf (__DATE__, "%63s %d %d", month, &day, &year); - /* LCOV_EXCL_START */ - if (status != 3) { - snprintf (cob_build_stamp, (size_t)COB_MINI_MAX, - "%s %s", __DATE__, __TIME__); - /* LCOV_EXCL_STOP */ - } else { - snprintf (cob_build_stamp, (size_t)COB_MINI_MAX, - "%s %2.2d %4.4d %s", month, day, year, __TIME__); - } - - printf ("cobcrun (%s) %s.%d\n", PACKAGE_NAME, PACKAGE_VERSION, PATCH_LEVEL); - puts ("Copyright (C) 2023 Free Software Foundation, Inc."); - printf (_("License GPLv3+: GNU GPL version 3 or later <%s>"), "https://gnu.org/licenses/gpl.html"); + printf ("cobcrun (%s) %s.%d\n", + PACKAGE_NAME, PACKAGE_VERSION, PATCH_LEVEL); + puts ("Copyright (C) 2024 Free Software Foundation, Inc."); + printf (_("License GPLv3+: GNU GPL version 3 or later <%s>"), + "https://gnu.org/licenses/gpl.html"); putchar ('\n'); puts (_("This is free software; see the source for copying conditions. There is NO\n" "warranty; not even for MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.")); - printf (_("Written by %s"), "Roger While, Simon Sobisch, Brian Tiffin"); putchar ('\n'); - printf (_("Built %s"), cob_build_stamp); - putchar ('\n'); - printf (_("Packaged %s"), COB_TAR_DATE); + printf (_("Written by %s"), "Roger While, Simon Sobisch, Brian Tiffin"); putchar ('\n'); + if (verbose_output) { + char cob_build_stamp[COB_MINI_BUFF]; + char month[64]; + int status, day, year; + + /* Set up build time stamp */ + memset (cob_build_stamp, 0, (size_t)COB_MINI_BUFF); + memset (month, 0, sizeof(month)); + day = 0; + year = 0; + status = sscanf (__DATE__, "%63s %d %d", month, &day, &year); + /* LCOV_EXCL_START */ + if (status != 3) { + snprintf (cob_build_stamp, (size_t)COB_MINI_MAX, + "%s %s", __DATE__, __TIME__); + /* LCOV_EXCL_STOP */ + } else { + snprintf (cob_build_stamp, (size_t)COB_MINI_MAX, + "%s %2.2d %4.4d %s", month, day, year, __TIME__); + } + printf (_("Built %s"), cob_build_stamp); + putchar ('\n'); + printf (_("Packaged %s"), COB_TAR_DATE); + putchar ('\n'); + } } /** @@ -140,12 +144,20 @@ cobcrun_print_usage (char * prog) " and any basename to the module preload list\n" " (COB_LIBRARY_PATH and/or COB_PRELOAD)")); putchar ('\n'); - printf (_("Report bugs to: %s\n" - "or (preferably) use the issue tracker via the home page."), "bug-gnucobol@gnu.org"); +#ifndef PACKAGE_BUGREPORT_URL + printf (_("Report bugs to: %s\n" + "or (preferably) use the issue tracker via the home page."), + PACKAGE_BUGREPORT); putchar ('\n'); - printf (_("GnuCOBOL home page: <%s>"), "https://www.gnu.org/software/gnucobol/"); +#else + puts (_("For bug reporting instructions, please see:")); + printf ("%s.\n", PACKAGE_BUGREPORT_URL); +#endif + printf (_("GnuCOBOL home page: <%s>"), + "https://www.gnu.org/software/gnucobol/"); putchar ('\n'); - printf (_("General help using GNU software: <%s>"), "https://www.gnu.org/gethelp/"); + printf (_("General help using GNU software: <%s>"), + "https://www.gnu.org/gethelp/"); putchar ('\n'); } diff --git a/cobc/ChangeLog b/cobc/ChangeLog index 58895a50a..c69bbf3a6 100644 --- a/cobc/ChangeLog +++ b/cobc/ChangeLog @@ -4,6 +4,12 @@ * pplex.l (output_line_directive): extracted from other places and extended to output compile from stdin as * codegen.c (output_cobol_info): output compile from stdin as + * cobc.c (cobc_print_version, cobc_print_shortversion, + process_command_line): build and package data only shown in verbose mode + which does not output the verbose "process" calls by default; + PACKAGE_NAME may now be overwritten by PKGVERSION (new configure option) + * help.c (cobc_print_usage): handle PACKAGE_BUGREPORT_URL as + alternative to mailing list, now resolved by PACKAGE_BUGREPORT 2024-10-01 Nicolas Berthier @@ -1336,7 +1342,7 @@ * codegen.c (output_perform_call): use statement reference to generate separate comment for PERFORM procedure or USE procedure * flag.def, codegen.c: new -fsection-exit-check - (cb_flag_section_exit_check) and -fimplicit-goback-check + (cb_flag_section_exit_check) and -fimplicit-goback-check (cb_flag_implicit_goback_check) * tree.h (cb_progam), parser.y (perform_procedure): add and set perform_thru_list for internal checks @@ -2385,7 +2391,7 @@ 2021-01-25 Simon Sobisch - * reserved.c: fixed context attribute of acu-extension POS + * reserved.c: fixed context attribute of acu-extension POS * parser.y, reserved.c, tree.h, cobc.h: added acu-extension MOVE WITH CONVERSION as PENDING @@ -2416,7 +2422,7 @@ * field.c, pplex.l, tree.c, typeck.c: fixed warning option querying enum instead of actual value via cb_warn_opt_val - + 2020-12-09 Ron Norman * cobc.c: now calls cob_get_sig_name from common.c to get signal name @@ -2432,7 +2438,7 @@ * typeck.c (syntax_check_ml_gen_name_list): additional parameter is_xml to distinguish between XML and JSON generation (messages, possible rules) * typeck.c (syntax_check_ml_gen_name_list): check of NAME ... IS OMITTED - + 2020-12-17 Simon Sobisch bug #571 revised: @@ -2661,7 +2667,7 @@ 2020-10-12 Ron Norman * typeck.c: Flag internal variables with 'flag_real_binary' - * codegen.c: Emit USAGE INDEX and internal binary variables + * codegen.c: Emit USAGE INDEX and internal binary variables as COB_TYPE_NUMERIC_COMP5 2020-10-06 Simon Sobisch @@ -3143,8 +3149,8 @@ 2020-02-10 Ron Norman - * cobc.c, cobc.h, codegen.c, help.c, warning.def: - Add new define CB_ERRWARNDEF + * cobc.c, cobc.h, codegen.c, help.c, warning.def: + Add new define CB_ERRWARNDEF 2020-02-05 Ron Norman @@ -3313,7 +3319,7 @@ 2019-09-15 Ron Norman * cobc.h: For HPUX set COB_ALLOW_UNALIGNED as undefined - * typeck.c: Emit ADD/SUBTRACT shortcut for COMP-5 only + * typeck.c: Emit ADD/SUBTRACT shortcut for COMP-5 only if COB_ALLOW_UNALIGNED defined * tree.h: Revert 'lock_mode' back to an 'int' * codegen.c: Changes for 'lock_mode' being an 'int' @@ -7335,7 +7341,7 @@ 2015-04-27 Ron Norman * config.c: don't store configuration values additional to the setting - + 2015-04-14 Ron Norman * cobc.c codegen.c common.h tree.h parser.y typeck.c: diff --git a/cobc/cobc.c b/cobc/cobc.c index 915353ed4..8fe0d93c0 100644 --- a/cobc/cobc.c +++ b/cobc/cobc.c @@ -2535,27 +2535,31 @@ cobc_sig_handler (int sig) static void cobc_print_version (void) { - printf ("cobc (%s) %s.%d\n", PACKAGE_NAME, PACKAGE_VERSION, PATCH_LEVEL); + printf ("cobc %s%s.%d\n", PKGVERSION, PACKAGE_VERSION, PATCH_LEVEL); puts ("Copyright (C) 2024 Free Software Foundation, Inc."); printf (_("License GPLv3+: GNU GPL version 3 or later <%s>"), "https://gnu.org/licenses/gpl.html"); putchar ('\n'); puts (_("This is free software; see the source for copying conditions. There is NO\n" "warranty; not even for MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.")); - printf (_("Written by %s"), "Keisuke Nishida, Roger While, Ron Norman, Simon Sobisch, Edward Hart"); - putchar ('\n'); - printf (_("Built %s"), cb_cobc_build_stamp); putchar ('\n'); - printf (_("Packaged %s"), COB_TAR_DATE); - putchar ('\n'); - printf ("%s %s", _("C version"), GC_C_VERSION_PRF GC_C_VERSION); + printf (_("Written by %s"), "Keisuke Nishida, Roger While, Ron Norman, Simon Sobisch, Edward Hart"); putchar ('\n'); + if (verbose_output) { + putchar ('\n'); + printf (_("Built %s"), cb_cobc_build_stamp); + putchar ('\n'); + printf (_("Packaged %s"), COB_TAR_DATE); + putchar ('\n'); + printf ("%s %s", _("C version"), GC_C_VERSION_PRF GC_C_VERSION); + putchar ('\n'); + } } static void cobc_print_shortversion (void) { - printf ("cobc (%s) %s.%d\n", - PACKAGE_NAME, PACKAGE_VERSION, PATCH_LEVEL); + printf ("cobc %s%s.%d\n", + PKGVERSION, PACKAGE_VERSION, PATCH_LEVEL); printf (_("Built %s"), cb_cobc_build_stamp); putchar ('\t'); printf (_("Packaged %s"), COB_TAR_DATE); @@ -3189,7 +3193,10 @@ process_command_line (const int argc, char **argv) /* --version */ cobc_print_version (); if (verbose_output) { - puts ("\n"); + /* temporarily reduce verbosity for not necessarily showing the process */ + const int verbose_output_sav = verbose_output--; + + putchar ('\n'); fflush (stdout); #ifdef _MSC_VER process ("cl.exe"); @@ -3203,7 +3210,8 @@ process_command_line (const int argc, char **argv) snprintf (cobc_buffer, cobc_buffer_size, "%s --version", cobc_cc); #endif #if (defined(__GNUC__) && !defined(__INTEL_COMPILER)) - if (verbose_output > 2) { + if (verbose_output > 1) { + verbose_output--; snprintf (cobc_buffer, cobc_buffer_size, "%s -v", cobc_cc); } #endif @@ -3212,6 +3220,7 @@ process_command_line (const int argc, char **argv) cobc_free (cobc_buffer); cobc_buffer = NULL; #endif + verbose_output = verbose_output_sav; } cobc_early_exit (EXIT_SUCCESS); diff --git a/cobc/help.c b/cobc/help.c index 53077416f..bb1ee3127 100644 --- a/cobc/help.c +++ b/cobc/help.c @@ -44,14 +44,20 @@ cobc_print_usage (char * prog) cobc_print_usage_dialect (); - putchar ('\n'); +#ifndef PACKAGE_BUGREPORT_URL printf (_("Report bugs to: %s\n" "or (preferably) use the issue tracker via the home page."), - "bug-gnucobol@gnu.org"); + PACKAGE_BUGREPORT); putchar ('\n'); - printf (_("GnuCOBOL home page: <%s>"), "https://www.gnu.org/software/gnucobol/"); +#else + puts (_("For bug reporting instructions, please see:")); + printf ("%s.\n", PACKAGE_BUGREPORT_URL); +#endif + printf (_("GnuCOBOL home page: <%s>"), + "https://www.gnu.org/software/gnucobol/"); putchar ('\n'); - printf (_("General help using GNU software: <%s>"), "https://www.gnu.org/gethelp/"); + printf (_("General help using GNU software: <%s>"), + "https://www.gnu.org/gethelp/"); putchar ('\n'); } diff --git a/configure.ac b/configure.ac index b7a516ab0..126e2a363 100644 --- a/configure.ac +++ b/configure.ac @@ -37,9 +37,11 @@ AC_REVISION([GnuCOBOL snapshot $Revision$]) AC_COPYRIGHT([This file is part of GnuCOBOL. Copyright (C) 2001-2012, 2014-2024 Free Software Foundation, Inc. + Written by Keisuke Nishida, Roger While, Ron Norman, Simon Sobisch, Edward Hart ]) + AC_CONFIG_SRCDIR([libcob.h]) AC_CONFIG_HEADERS([config.h]) AC_CONFIG_TESTDIR([tests]) @@ -58,6 +60,50 @@ AC_CONFIG_FILES([tests/atlocal], [chmod +x tests/atlocal]) AC_CONFIG_FILES([tests/run_prog_manual.sh], [chmod +x tests/run_prog_manual.sh]) +dnl Support the --with-pkgversion configure option, +dnl inspired from GCC's ACX_PKGVERSION. +AC_ARG_WITH([pkgversion], + [AS_HELP_STRING([--with-pkgversion=PKG], + [Use PKG in the version string in place of "$PACKAGE_NAME"])], + [case "$withval" in + yes) AC_MSG_ERROR([package version not specified]) ;; + no) PKGVERSION= ;; + *) PKGVERSION="($withval) " ;; + esac], + [PKGVERSION="($PACKAGE_NAME) "]) + +# AC_SUBST(PKGVERSION) +AC_DEFINE_UNQUOTED([PKGVERSION], ["$PKGVERSION"], [PKG version string]) + + +dnl Support the --with-bugurl configure option, +dnl inspired from GCC's ACX_BUGURL. +AC_ARG_WITH([bugurl], + [AS_HELP_STRING([--with-bugurl=URL], + [Direct users to URL to report a bug, instead of mailing list])], + [case "$withval" in + yes) AC_MSG_ERROR([bug URL not specified]) ;; + no) BUGURL= ;; + *) BUGURL="$withval" ;; + esac], + [ # BUGURL="$PACKAGE_BUGREPORT" + ]) + + case ${BUGURL} in + "") + # REPORT_BUGS_TO= + # REPORT_BUGS_TEXI= + ;; + *) + AC_DEFINE_UNQUOTED([PACKAGE_BUGREPORT_URL], ["<$BUGURL>"], [Bug URL instead of mailing list]) + # REPORT_BUGS_TO="<$BUGURL>" + # REPORT_BUGS_TEXI=@uref{`echo "$BUGURL" | sed 's/@/@@/g'`} + ;; + esac; + # AC_SUBST(REPORT_BUGS_TO) + # AC_SUBST(REPORT_BUGS_TEXI) + + # In general: don't export/setenv but pass as option to configure # this has the benefit that re-runs will take the same and "sudo" # or later "make" (possibly as different user) will use the same diff --git a/libcob/ChangeLog b/libcob/ChangeLog index 9056a9101..551dd80aa 100644 --- a/libcob/ChangeLog +++ b/libcob/ChangeLog @@ -1,4 +1,9 @@ +2024-10-02 Simon Sobisch + + * common.c (print_version): PACKAGE_NAME may now be overwritten + by PKGVERSION (new configure option) + 2024-09-29 Simon Sobisch * numeric.c, common.c (print_info_detailed): drop COB_LI_IS_LL diff --git a/libcob/common.c b/libcob/common.c index c6a83ac25..c028b91b5 100644 --- a/libcob/common.c +++ b/libcob/common.c @@ -9681,14 +9681,17 @@ print_version (void) set_cob_build_stamp (cob_build_stamp); - printf ("libcob (%s) %s.%d\n", - PACKAGE_NAME, PACKAGE_VERSION, PATCH_LEVEL); - puts ("Copyright (C) 2023 Free Software Foundation, Inc."); - printf (_("License LGPLv3+: GNU LGPL version 3 or later <%s>"), "https://gnu.org/licenses/lgpl.html"); + printf ("libcob %s%s.%d\n", + PKGVERSION, PACKAGE_VERSION, PATCH_LEVEL); + puts ("Copyright (C) 2024 Free Software Foundation, Inc."); + printf (_("License LGPLv3+: GNU LGPL version 3 or later <%s>"), + "https://gnu.org/licenses/lgpl.html"); putchar ('\n'); puts (_("This is free software; see the source for copying conditions. There is NO\n" "warranty; not even for MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.")); - printf (_("Written by %s"), "Keisuke Nishida, Roger While, Ron Norman, Simon Sobisch, Edward Hart"); + putchar ('\n'); + printf (_("Written by %s"), "Keisuke Nishida, Roger While, " + "Ron Norman, Simon Sobisch, Edward Hart"); putchar ('\n'); /* TRANSLATORS: This msgid is intended as the "Packaged" msgid, %s expands to date and time */ From c53ae5f803518dc7a0e1e88ee08ac060e423ca1b Mon Sep 17 00:00:00 2001 From: sf-mensch Date: Wed, 2 Oct 2024 23:21:53 +0000 Subject: [PATCH 04/29] signal handler updates * cobc/cobc.c (cobc_sig_handler): skip abort message for SIGPIPE * libcob/common.c: * (cob_sig_handler): fixed early exit from signal handler in case of errors during write to stderr, adjusted macros accordingly * (cob_sig_handler): flush stdout+stderr for fixed set of signals where this is known to work * (cob_reg_sighnd): if signal handler is enabled from outside the COBOL runtime (like via cobc), do the initialization of the internal signal text table (was empty before) * (cob_sig_handler): early exit for SIGPIPE without output if signal handler is used without any COBOL modules active (like via cobc) * (cob_sig_handler): fixed coding error that led to missing output of catched signal name added tests for signal handling, these may need to be skipped because of not being completely portable --- cobc/ChangeLog | 1 + cobc/cobc.c | 11 +-- libcob/ChangeLog | 11 +++ libcob/common.c | 104 ++++++++++++++++++++------- tests/testsuite.src/used_binaries.at | 86 ++++++++++++++++++++++ 5 files changed, 182 insertions(+), 31 deletions(-) diff --git a/cobc/ChangeLog b/cobc/ChangeLog index c69bbf3a6..8c5853b8e 100644 --- a/cobc/ChangeLog +++ b/cobc/ChangeLog @@ -10,6 +10,7 @@ PACKAGE_NAME may now be overwritten by PKGVERSION (new configure option) * help.c (cobc_print_usage): handle PACKAGE_BUGREPORT_URL as alternative to mailing list, now resolved by PACKAGE_BUGREPORT + * cobc.c (cobc_sig_handler): skip abort message for SIGPIPE 2024-10-01 Nicolas Berthier diff --git a/cobc/cobc.c b/cobc/cobc.c index 8fe0d93c0..de9c1d6f1 100644 --- a/cobc/cobc.c +++ b/cobc/cobc.c @@ -2502,7 +2502,13 @@ cobc_sig_handler (int sig) int ret = 0; #endif - cobc_abort_msg (); +#ifdef SIGPIPE + if (sig == SIGPIPE) ret = 1; +#endif + + if (!ret) { + cobc_abort_msg (); + } #if defined (SIGINT) || defined (SIGQUIT) || defined (SIGTERM) || defined (SIGPIPE) #ifdef SIGINT if (sig == SIGINT) ret = 1; @@ -2513,9 +2519,6 @@ cobc_sig_handler (int sig) #ifdef SIGTERM if (sig == SIGTERM) ret = 1; #endif -#ifdef SIGPIPE - if (sig == SIGPIPE) ret = 1; -#endif /* LCOV_EXCL_START */ if (!ret) { diff --git a/libcob/ChangeLog b/libcob/ChangeLog index 551dd80aa..b5a148c41 100644 --- a/libcob/ChangeLog +++ b/libcob/ChangeLog @@ -3,6 +3,17 @@ * common.c (print_version): PACKAGE_NAME may now be overwritten by PKGVERSION (new configure option) + * common.c (cob_sig_handler): fixed early exit from signal handler + in case of errors during write to stderr, adjusted macros accordingly + * common.c (cob_sig_handler): flush stdout+stderr for fixed set of signals + where this is known to work + * common.c (cob_reg_sighnd): if signal handler is enabled from outside the + COBOL runtime (like via cobc), do the initialization of the internal signal + text table (was empty before) + * common.c (cob_sig_handler): early exit for SIGPIPE without output if + signal handler is used without any COBOL modules active (like via cobc) + * common.c (cob_sig_handler): fixed coding error that led to missing output + of catched signal name 2024-09-29 Simon Sobisch diff --git a/libcob/common.c b/libcob/common.c index c028b91b5..bf82f5eec 100644 --- a/libcob/common.c +++ b/libcob/common.c @@ -1021,15 +1021,29 @@ set_source_location (const char **file, unsigned int *line) } /* write integer to stderr using fixed buffer */ +#define write_to_stderr_or_true_int(i) \ + (write (STDERR_FILENO, ss_itoa_buf, ss_itoa_u10 (i)) == -1) #define write_to_stderr_or_return_int(i) \ - if (write (STDERR_FILENO, ss_itoa_buf, ss_itoa_u10 (i)) == -1) return + if (write_to_stderr_or_true_int (i)) return +#define write_to_stderr_until_error_int(i, err) \ + if (!err) err = write_to_stderr_or_true_int (i) + /* write char array (constant C string) to stderr */ +#define write_to_stderr_or_true_arr(ch_arr) \ + (write (STDERR_FILENO, ch_arr, sizeof (ch_arr) - 1) == -1) #define write_to_stderr_or_return_arr(ch_arr) \ - if (write (STDERR_FILENO, ch_arr, sizeof (ch_arr) - 1) == -1) return + if (write_to_stderr_or_true_arr (ch_arr)) return +#define write_to_stderr_until_error_arr(ch_arr,err) \ + if (!err) err = write_to_stderr_or_true_arr (ch_arr) + /* write string to stderr, byte count computed with strlen, str is evaluated twice */ +#define write_to_stderr_or_true_str(str) \ + (write (STDERR_FILENO, str, strlen (str)) == -1) #define write_to_stderr_or_return_str(str) \ - if (write (STDERR_FILENO, str, strlen (str)) == -1) return + if (write_to_stderr_or_true_str (str)) return +#define write_to_stderr_until_error_str(str,err) \ + if (!err) err = write_to_stderr_or_true_str (str) /* write integer to fileno using fixed buffer */ #define write_or_return_int(fileno,i) \ @@ -1114,6 +1128,7 @@ cob_sig_handler (int sig) const char *msg; char signal_text[COB_MINI_BUFF] = { 0 }; size_t str_len; + int write_err = 0; #if defined (HAVE_SIGACTION) && !defined (SA_RESETHAND) struct sigaction sa; @@ -1131,11 +1146,38 @@ cob_sig_handler (int sig) sig_is_handled = 1; #endif -#if 0 /* We do not generally flush whatever we may have in our streams - as stdio is not signal-safe; - we _may_ do this if not SIGSEGV/SIGBUS/SIGABRT */ - fflush (stdout); - fflush (stderr); + + /* We do not generally flush whatever we may have in our streams + as stdio is not signal-safe; + we _may_ do this if not SIGSEGV/SIGBUS/SIGABRT (but as we don't know + if all of those are defined we only flush on a positive list)*/ + switch (sig) { + case -1: +#ifdef SIGPIPE + case SIGPIPE: +#endif +#ifdef SIGTERM + case SIGTERM: +#endif +#ifdef SIGINT + case SIGINT: +#endif +#ifdef SIGHUP + case SIGHUP: +#endif + fflush (stderr); + fflush (stdout); + break; + default: + break; + } + +#ifdef SIGPIPE + /* early exit for non-active COBOL runtime */ + if (sig == SIGPIPE + && !cob_initialized) { + goto exit_handler; + } #endif signal_name = cob_get_sig_name (sig); @@ -1143,9 +1185,9 @@ cob_sig_handler (int sig) if (signal_name == signals[NUM_SIGNALS].shortname) { /* not translated as it is a very unlikely error case */ signal_name = signals[NUM_SIGNALS].description; /* translated unknown */ - write_to_stderr_or_return_arr ("\ncob_sig_handler caught not handled signal: "); - write_to_stderr_or_return_int (sig); - write_to_stderr_or_return_arr ("\n"); + write_to_stderr_until_error_arr ("\ncob_sig_handler caught not handled signal: ", write_err); + write_to_stderr_until_error_int (sig, write_err); + write_to_stderr_until_error_arr ("\n", write_err); } /* LCOV_EXCL_STOP */ @@ -1182,29 +1224,33 @@ cob_sig_handler (int sig) #endif cob_exit_screen (); - write_to_stderr_or_return_arr ("\n"); - cob_get_source_line (); - output_source_location (); + write_to_stderr_until_error_arr ("\n", write_err); + if (!write_err) { + cob_get_source_line (); + output_source_location (); - msg = cob_get_sig_description (sig); - write_to_stderr_or_return_str (msg); + msg = cob_get_sig_description (sig); + write_to_stderr_until_error_str (msg, write_err); + } - /* setup "signal %s" */ - str_len = strlen (signal_msgid); - memcpy (signal_text, signal_msgid, str_len++); - signal_text[str_len] = ' '; - memcpy (signal_text + str_len, signal_name, strlen (signal_name)); + if (!write_err) { + /* setup "signal %s" */ + str_len = strlen (signal_msgid); + memcpy (signal_text, signal_msgid, str_len); + signal_text[str_len++] = ' '; + memcpy (signal_text + str_len, signal_name, strlen (signal_name)); - write_to_stderr_or_return_arr (" ("); - write_to_stderr_or_return_str (signal_text); - write_to_stderr_or_return_arr (")\n\n"); + write_to_stderr_until_error_arr (" (", write_err); + write_to_stderr_until_error_str (signal_text, write_err); + write_to_stderr_until_error_arr (")\n\n", write_err); + } if (cob_initialized) { if (abort_reason[0] == 0) { memcpy (abort_reason, signal_text, COB_MINI_BUFF); #if 0 /* Is there a use in this message ?*/ - write_to_stderr_or_return_str (abnormal_termination_msgid); - write_to_stderr_or_return_arr ("\n"); + write_to_stderr_until_error_str (abnormal_termination_msgid, write_err); + write_to_stderr_until_error_arr ("\n", write_err); #endif } } @@ -1235,6 +1281,7 @@ cob_sig_handler (int sig) break; } +exit_handler: /* call external signal handler if registered */ if (cob_ext_sighdl != NULL) { (*cob_ext_sighdl) (sig); @@ -3842,6 +3889,7 @@ cob_reg_sighnd (void (*sighnd) (int)) { if (!cob_initialized) { cob_set_signal (); + cob_init_sig_descriptions (); } cob_ext_sighdl = sighnd; } @@ -8832,7 +8880,6 @@ cob_runtime_warning_external (const char *caller_name, const int cob_reference, if (!cobsetptr->cob_display_warn) { return; } - if (!(caller_name && *caller_name)) caller_name = "unknown caller"; /* Prefix */ if (cob_reference) { @@ -8843,7 +8890,10 @@ cob_runtime_warning_external (const char *caller_name, const int cob_reference, } else { fprintf (stderr, "libcob: "); } + fprintf (stderr, _("warning: ")); + + if (!(caller_name && *caller_name)) caller_name = "unknown caller"; fprintf (stderr, "%s: ", caller_name); /* Body */ diff --git a/tests/testsuite.src/used_binaries.at b/tests/testsuite.src/used_binaries.at index 4dabfc80c..0e200a960 100644 --- a/tests/testsuite.src/used_binaries.at +++ b/tests/testsuite.src/used_binaries.at @@ -1356,3 +1356,89 @@ AT_CHECK([$GREP 'sub/copy/PROC.cpy' prog.d], [0], [ignore], [], [ AT_CLEANUP +AT_SETUP([signal handling SIGPIPE cobc]) +AT_KEYWORDS([runmisc]) + +# the runtime is not initialized, so we get out without any error message in libcob +# and we also don't raise anything in cobc either +AT_CHECK([$COBC --help | head], [0], [ignore], []) + +AT_CLEANUP + + +AT_SETUP([signal handling SIGPIPE in COBOL]) +AT_KEYWORDS([runmisc]) + +AT_DATA([prog.cob], [ + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + PROCEDURE DIVISION. + 00. DISPLAY '1'. DISPLAY '2'. DISPLAY '3'. DISPLAY '4'. + DISPLAY '5'. DISPLAY '6'. DISPLAY '7'. DISPLAY '8'. + EX. STOP RUN. +]) + +AT_CHECK([$COMPILE prog.cob], [0], [], []) +AT_CHECK([$COBCRUN_DIRECT ./prog| head -n 2], [0], +[1 +2 +], []) + +AT_CLEANUP + + +AT_SETUP([signal handling SIGTERM in COBOL]) +AT_KEYWORDS([runmisc stack stacktrace]) + +AT_DATA([prog.cob], [ + IDENTIFICATION DIVISION. + PROGRAM-ID. 'prog'. + PROCEDURE DIVISION. + 00. DISPLAY '1'. + CALL 'wait'. DISPLAY '2'. + EX. STOP RUN. + END PROGRAM 'prog'. + IDENTIFICATION DIVISION. + PROGRAM-ID. 'wait'. + PROCEDURE DIVISION. + 00. PERFORM DO-WAIT. + EX. GOBACK. + DO-WAIT. CONTINUE AFTER 10 SECONDS. + END PROGRAM 'wait'. +]) + +AT_CHECK([$COMPILE prog.cob], [0], [], []) + +# note: the stack trace, while enabled per default, is globally disabled in the testsuite +AT_CHECK([$COBCRUN_DIRECT ./prog & cobpid=$! +sleep 6 +kill -15 $cobpid], [0], +[1 +], +[ +prog.cob:14: termination (signal SIGTERM) + +]) +AT_CHECK([COB_STACKTRACE=1 $COBCRUN_DIRECT ./prog a "b c" & cobpid=$! +sleep 6 +kill -15 $cobpid], [0], +[1 +], +[ +prog.cob:14: termination (signal SIGTERM) + + + Last statement of "wait" was CONTINUE AFTER + DO-WAIT at prog.cob:14 + 00 at prog.cob:12 + ENTRY wait at prog.cob:12 + Last statement of "prog" was CALL + 00 at prog.cob:6 + ENTRY prog at prog.cob:5 + Started by ./prog + a + b c +]) + +AT_CLEANUP + From 929b403b68ffedce147598f57eff79dc02590d6f Mon Sep 17 00:00:00 2001 From: sf-mensch Date: Thu, 3 Oct 2024 00:08:33 +0000 Subject: [PATCH 05/29] fix [r5349] missing PKGVERSION for build_windows --- build_windows/config.h.in | 9 +++++++++ 1 file changed, 9 insertions(+) diff --git a/build_windows/config.h.in b/build_windows/config.h.in index d7294dc64..44343b870 100644 --- a/build_windows/config.h.in +++ b/build_windows/config.h.in @@ -768,6 +768,9 @@ /* Define to 1 if you have the header file. */ /* #undef HAVE_XCURSES_H */ +/* Define as const if the declaration of iconv() needs const. */ +/* #undef ICONV_CONST */ + /* Define to the sub-directory where libtool stores uninstalled libraries. */ /* #undef LT_OBJDIR */ @@ -780,6 +783,9 @@ /* Define to the address where bug reports for this package should be sent. */ #define PACKAGE_BUGREPORT "bug-gnucobol@gnu.org" +/* Bug URL instead of mailing list */ +/* #undef PACKAGE_BUGREPORT_URL */ + /* Define to the full name of this package. */ #define PACKAGE_NAME "GnuCOBOL" @@ -798,6 +804,9 @@ /* Define a patch level (numeric, max. 8 digits) */ #define PATCH_LEVEL COB_NUM_TAR_DATE +/* PKG version string */ +#define PKGVERSION "(" PACKAGE_NAME ") " + // Use \ to escape things, for example \\ for using in paths // Use \" for paths with spaces From 3f897122aacdd6610c14117b28442013a4574cde Mon Sep 17 00:00:00 2001 From: sf-mensch Date: Fri, 4 Oct 2024 15:32:44 +0000 Subject: [PATCH 06/29] signal and stack handling update libcob: * common.c (cob_sig_handler): moved call of cob_exit_screen_from_signal from ss_terminate_routines here instead of calling cob_exit_screen * common.c (cob_sig_handler, cob_stack_trace_internal, cob_runtime_warning_ss): now using an internal buffer to output data instead of potentially hundreds of small direct writes, output the complete buffer when half-full oir at the end * common.c (get_source_location): renamed from output_source_location, now writing to a specified buffer, returning the length, instead of direct write to stderr * common.c (output_procedure_stack_entry): use buffer instead of direct write to stderr, now returning the length * common.c (write_until_fail, strcat_to_buf, intcat_to_buff): new helper functions * common.c (cob_sig_handler): moved call of cob_exit_screen_from_signal from ss_terminate_routines here instead of calling cob_exit_screen * common.c (cob_runtime_warning_ss), coblocal.h, fileio.c (cob_exit_fileio_msg_only): changed signature, now returning nonzero if write to stderr wasn't sucessfull * common.c (cob_runtime_warning, cob_runtime_warning_external): use all buffered io again additional: libcob/common.c (cob_load_config_file): fix format truncation warning by explicit checking for it --- libcob/ChangeLog | 27 +++ libcob/coblocal.h | 2 +- libcob/common.c | 435 +++++++++++++++++++++++++--------------------- libcob/fileio.c | 11 +- 4 files changed, 275 insertions(+), 200 deletions(-) diff --git a/libcob/ChangeLog b/libcob/ChangeLog index b5a148c41..8b440116e 100644 --- a/libcob/ChangeLog +++ b/libcob/ChangeLog @@ -1,4 +1,29 @@ +2024-10-04 Simon Sobisch + + * common.c (cob_sig_handler): moved call of cob_exit_screen_from_signal + from ss_terminate_routines here instead of calling cob_exit_screen + * common.c (cob_sig_handler, cob_stack_trace_internal, + cob_runtime_warning_ss): now using an internal buffer to output data + instead of potentially hundreds of small direct writes, output the + complete buffer when half-full oir at the end + * common.c (get_source_location): renamed from output_source_location, + now writing to a specified buffer, returning the length, instead of + direct write to stderr + * common.c (output_procedure_stack_entry): use buffer instead of direct + write to stderr, now returning the length + * common.c (write_until_fail, strcat_to_buf, intcat_to_buff): new helper + functions + * common.c (cob_sig_handler): moved call of cob_exit_screen_from_signal + from ss_terminate_routines here instead of calling cob_exit_screen + * common.c (cob_runtime_warning_ss), coblocal.h, + fileio.c (cob_exit_fileio_msg_only): changed signature, now returning + nonzero if write to stderr wasn't sucessfull + * common.c (cob_runtime_warning, cob_runtime_warning_external): + use all buffered io again + * common.c (cob_load_config_file): fix format truncation warning by + explicit checking for it + 2024-10-02 Simon Sobisch * common.c (print_version): PACKAGE_NAME may now be overwritten @@ -61,6 +86,8 @@ * common.h, common.c (cob_cleanup_thread): fix declaration * common.c: drop includes found in coblocal.h * common.c (cob_alloc_module): changed type and name of cob_mod_ptr + * common.h, coblocal.h: added pragma once for better supporting clangd + in single-file mode 2024-08-06 Simon Sobisch diff --git a/libcob/coblocal.h b/libcob/coblocal.h index 11eaf23fd..a8b8e2c6c 100644 --- a/libcob/coblocal.h +++ b/libcob/coblocal.h @@ -577,7 +577,7 @@ COB_HIDDEN char *cob_int_to_formatted_bytestring (int, char*); COB_HIDDEN char *cob_strcat (char*, char*, int); COB_HIDDEN char *cob_strjoin (char**, int, char*); -COB_HIDDEN void cob_runtime_warning_ss (const char *, const char *); +COB_HIDDEN int cob_runtime_warning_ss (const char *, const char *); DECLNORET COB_HIDDEN void cob_hard_failure (void) COB_A_NORETURN; diff --git a/libcob/common.c b/libcob/common.c index bf82f5eec..cfc30f39f 100644 --- a/libcob/common.c +++ b/libcob/common.c @@ -18,6 +18,7 @@ along with GnuCOBOL. If not, see . */ +#include "libcob/common.h" #include "tarstamp.h" #include "config.h" @@ -800,7 +801,6 @@ ss_terminate_routines (void) return; } cob_exit_fileio_msg_only (); - cob_exit_screen_from_signal(1); if (COB_MODULE_PTR && abort_reason[0] != 0) { if (cobsetptr->cob_stacktrace) { @@ -824,7 +824,7 @@ cob_terminate_routines (void) } fflush (stderr); - cob_prof_end(); + cob_prof_end (); cob_exit_fileio_msg_only (); if (COB_MODULE_PTR && abort_reason[0] != 0) { @@ -1020,66 +1020,59 @@ set_source_location (const char **file, unsigned int *line) } } -/* write integer to stderr using fixed buffer */ -#define write_to_stderr_or_true_int(i) \ - (write (STDERR_FILENO, ss_itoa_buf, ss_itoa_u10 (i)) == -1) -#define write_to_stderr_or_return_int(i) \ - if (write_to_stderr_or_true_int (i)) return -#define write_to_stderr_until_error_int(i, err) \ - if (!err) err = write_to_stderr_or_true_int (i) - -/* write char array (constant C string) to stderr */ -#define write_to_stderr_or_true_arr(ch_arr) \ - (write (STDERR_FILENO, ch_arr, sizeof (ch_arr) - 1) == -1) -#define write_to_stderr_or_return_arr(ch_arr) \ - if (write_to_stderr_or_true_arr (ch_arr)) return -#define write_to_stderr_until_error_arr(ch_arr,err) \ - if (!err) err = write_to_stderr_or_true_arr (ch_arr) - -/* write string to stderr, byte count computed with strlen, - str is evaluated twice */ -#define write_to_stderr_or_true_str(str) \ - (write (STDERR_FILENO, str, strlen (str)) == -1) -#define write_to_stderr_or_return_str(str) \ - if (write_to_stderr_or_true_str (str)) return -#define write_to_stderr_until_error_str(str,err) \ - if (!err) err = write_to_stderr_or_true_str (str) - -/* write integer to fileno using fixed buffer */ -#define write_or_return_int(fileno,i) \ - if (write (fileno, ss_itoa_buf, ss_itoa_u10 (i)) == -1) return -/* write char array (constant C string) to fileno */ -#define write_or_return_arr(fileno, ch_arr) \ - if (write (fileno, ch_arr, sizeof (ch_arr) - 1) == -1) return -/* write string to fileno, byte count computed with strlen, - str is evaluated twice */ -#define write_or_return_str(fileno,str) \ - if (write (fileno, str, strlen (str)) == -1) return - -#if 0 /* unused */ -/* write buffer with given byte count to stderr */ -#define write_to_stderr_or_return_buf(buff,count) \ - if (write (STDERR_FILENO, buff, count) == -1) return -/* write buffer with given byte count to fileno */ -#define write_or_return_buf(fileno,buff,count) \ - if (write (fileno, buff, count) == -1) return -#endif +/* writes data to fd, returns either the initial size or -1 in case of error */ +static COB_INLINE cob_s64_t +write_until_fail (int fd, const void *data, size_t size) +{ + register cob_s64_t size_to_write = size; + while (size_to_write > 0) { + long bytes_written = write (fd, data, (size_t)size_to_write); + if (bytes_written == -1) { + return 1; + } + data += bytes_written; + size_to_write -= bytes_written; -static void -output_source_location (void) + } + return size; +} + +static COB_INLINE COB_A_INLINE size_t +strcat_to_buff (char *buff, const char *str) +{ + const size_t len = strlen (str); + memcpy (buff, str, len); + return len; +} + +static COB_INLINE COB_A_INLINE size_t +intcat_to_buff (char *buff, const int num) +{ + ss_itoa_u10 (num); + return strcat_to_buff (buff, ss_itoa_buf); +} + +/* stores source location into buff, returns size written (without trailing NUL) */ +static size_t +get_source_location (char *buff) { const char *source_file; unsigned int source_line; + size_t pos = 0; + set_source_location (&source_file, &source_line); if (source_file) { - write_to_stderr_or_return_str (source_file); + pos += strcat_to_buff (buff, source_file); if (source_line) { - write_to_stderr_or_return_arr (":"); - write_to_stderr_or_return_int ((int)source_line); + buff[pos++] = ':'; + pos += intcat_to_buff (buff + pos, source_line); } - write_to_stderr_or_return_arr (": "); + buff[pos++] = ':'; + buff[pos++] = ' '; } + buff[pos] = 0; + return pos; } static int @@ -1124,11 +1117,11 @@ create_dumpfile (void) static void cob_sig_handler (int sig) { + char buff [COB_MEDIUM_BUFF]; + char signal_text[COB_MINI_BUFF]; const char *signal_name; const char *msg; - char signal_text[COB_MINI_BUFF] = { 0 }; - size_t str_len; - int write_err = 0; + size_t pos = 0; #if defined (HAVE_SIGACTION) && !defined (SA_RESETHAND) struct sigaction sa; @@ -1184,10 +1177,10 @@ cob_sig_handler (int sig) /* LCOV_EXCL_START */ if (signal_name == signals[NUM_SIGNALS].shortname) { /* not translated as it is a very unlikely error case */ + pos += strcat_to_buff (buff + pos, "\n" "cob_sig_handler caught not handled signal: "); + pos += intcat_to_buff (buff + pos, sig); + buff[pos++] = '\n'; signal_name = signals[NUM_SIGNALS].description; /* translated unknown */ - write_to_stderr_until_error_arr ("\ncob_sig_handler caught not handled signal: ", write_err); - write_to_stderr_until_error_int (sig, write_err); - write_to_stderr_until_error_arr ("\n", write_err); } /* LCOV_EXCL_STOP */ @@ -1222,38 +1215,44 @@ cob_sig_handler (int sig) #else (void)signal (sig, SIG_DFL); #endif - cob_exit_screen (); + cob_exit_screen_from_signal (1); - write_to_stderr_until_error_arr ("\n", write_err); - if (!write_err) { - cob_get_source_line (); - output_source_location (); + buff[pos++] = '\n'; - msg = cob_get_sig_description (sig); - write_to_stderr_until_error_str (msg, write_err); - } + /* buffer: "prog.cob:1: " */ + pos += get_source_location (buff + pos); + /* buffer: "signal desc" */ + msg = cob_get_sig_description (sig); + pos += strcat_to_buff (buff + pos, msg); + /* setup "signal %s" (for output and abort reason) */ + { - if (!write_err) { - /* setup "signal %s" */ - str_len = strlen (signal_msgid); + const size_t str_len = strlen (signal_msgid); memcpy (signal_text, signal_msgid, str_len); - signal_text[str_len++] = ' '; - memcpy (signal_text + str_len, signal_name, strlen (signal_name)); - - write_to_stderr_until_error_arr (" (", write_err); - write_to_stderr_until_error_str (signal_text, write_err); - write_to_stderr_until_error_arr (")\n\n", write_err); + signal_text[str_len] = ' '; + strcpy (signal_text + str_len + 1, signal_name); } + /* buffer: " (signal %s)" */ + buff[pos++] = ' '; + buff[pos++] = '('; + pos += strcat_to_buff (buff + pos, signal_text); + buff[pos++] = ')'; + + buff[pos++] = '\n'; + buff[pos++] = '\n'; + if (cob_initialized) { if (abort_reason[0] == 0) { memcpy (abort_reason, signal_text, COB_MINI_BUFF); #if 0 /* Is there a use in this message ?*/ - write_to_stderr_until_error_str (abnormal_termination_msgid, write_err); - write_to_stderr_until_error_arr ("\n", write_err); + pos += strcat_to_buff (buff + pos, abnormal_termination_msgid); + buff[pos++] = '\n'; #endif } } + buff[pos] = 0; + write_until_fail (STDERR_FILENO, buff, pos); /* early coredump if requested would be nice, but that is not signal-safe so do SIGABRT later... */ @@ -8698,8 +8697,8 @@ cob_load_config_file (const char *config_file, int isoptional) size = strlen (buff); if (size != 0 && buff[size] == SLASH_CHAR) buff[--size] = 0; if (size != 0) { - snprintf (filename, (size_t)COB_FILE_MAX, "%s%c%s", buff, SLASH_CHAR, - config_file); + snprintf (filename, (size_t)COB_FILE_MAX, "%s%c%s", + buff, SLASH_CHAR, config_file); if (access (filename, F_OK) == 0) { /* and prefixed file exist */ config_file = filename; /* Prefix last directory */ } else { @@ -8709,15 +8708,17 @@ cob_load_config_file (const char *config_file, int isoptional) } if (filename[0] == 0) { /* check for COB_CONFIG_DIR (use default if not in environment) */ + int size; penv = getenv ("COB_CONFIG_DIR"); if (penv != NULL) { - snprintf (filename, (size_t)COB_FILE_MAX, "%s%c%s", + size = snprintf (filename, (size_t)COB_FILE_MAX, "%s%c%s", penv, SLASH_CHAR, config_file); } else { - snprintf (filename, (size_t)COB_FILE_MAX, "%s%c%s", + size = snprintf (filename, (size_t)COB_FILE_MAX, "%s%c%s", COB_CONFIG_DIR, SLASH_CHAR, config_file); } - if (access (filename, F_OK) == 0) { /* and prefixed file exist */ + if (size > 0 && size < COB_FILE_MAX + && access (filename, F_OK) == 0) { /* and prefixed file exist */ config_file = filename; /* Prefix COB_CONFIG_DIR */ } } @@ -8882,15 +8883,13 @@ cob_runtime_warning_external (const char *caller_name, const int cob_reference, } /* Prefix */ + fprintf (stderr, "libcob: "); if (cob_reference) { - fflush (stderr); /* necessary as we write afterwards */ - write_to_stderr_or_return_arr ("libcob: "); + char buff[COB_MINI_BUFF]; cob_get_source_line (); - output_source_location (); - } else { - fprintf (stderr, "libcob: "); - } - + get_source_location (buff); + fprintf (stderr, "%s", buff); + } fprintf (stderr, _("warning: ")); if (!(caller_name && *caller_name)) caller_name = "unknown caller"; @@ -8906,26 +8905,34 @@ cob_runtime_warning_external (const char *caller_name, const int cob_reference, fflush (stderr); } -void +/* output non-buffered (signal-async-safe) runtime warning, + returning 1 if write to stderr was not sucessfull */ +int cob_runtime_warning_ss (const char *msg, const char *addition) { - if (cobsetptr && !cobsetptr->cob_display_warn) { - return; - } + if (!cobsetptr + || cobsetptr->cob_display_warn) { + char buff[COB_MEDIUM_BUFF]; + size_t pos = 0; - /* Prefix */ - write_to_stderr_or_return_arr ("libcob: "); - output_source_location (); - write_to_stderr_or_return_str (warning_msgid); + /* Prefix */ + pos += strcat_to_buff (buff, "libcob: "); + pos += get_source_location (buff + pos); + pos += strcat_to_buff (buff + pos, warning_msgid); - /* Body */ - write_to_stderr_or_return_str (msg); - if (addition) { - write_to_stderr_or_return_str (addition); - } + /* Body */ + pos += strcat_to_buff (buff + pos, msg); + if (addition) { + pos += strcat_to_buff (buff + pos, addition); + } - /* Postfix */ - write_to_stderr_or_return_arr ("\n"); + /* Postfix */ + buff[pos++] = '\n'; + buff[pos] = 0; + + return (write_until_fail (STDERR_FILENO, buff, pos) == -1); + } + return 0; } void @@ -8937,14 +8944,16 @@ cob_runtime_warning (const char *fmt, ...) return; } - fflush (stderr); /* necessary as we write afterwards */ /* Prefix */ - write_to_stderr_or_return_arr ("libcob: "); - cob_get_source_line (); - output_source_location (); - - fprintf (stderr, _("warning: ")); /* back to stdio */ + fprintf (stderr, "libcob: "); + { + char buff[COB_MINI_BUFF]; + cob_get_source_line (); + get_source_location (buff); + fprintf (stderr, "%s", buff); + } + fprintf (stderr, _("warning: ")); /* Body */ va_start (args, fmt); @@ -10232,9 +10241,9 @@ void cob_set_main_argv0 (const int argc, char **argv) int i; #ifdef _WIN32 - s = cob_malloc ((size_t)COB_LARGE_BUFF); - i = GetModuleFileNameA (NULL, s, COB_LARGE_MAX); - if (i > 0 && i < COB_LARGE_BUFF) { + s = cob_malloc ((size_t)COB_MEDIUM_BUFF); + i = GetModuleFileNameA (NULL, s, COB_MEDIUM_MAX); + if (i > 0 && i < COB_MEDIUM_BUFF) { cobglobptr->cob_main_argv0 = cob_strdup (s); cob_free (s); return; @@ -10252,9 +10261,9 @@ void cob_set_main_argv0 (const int argc, char **argv) path = NULL; } if (path) { - s = cob_malloc ((size_t)COB_LARGE_BUFF); - i = (int)readlink (path, s, (size_t)COB_LARGE_MAX); - if (i > 0 && i < COB_LARGE_BUFF) { + s = cob_malloc ((size_t)COB_MEDIUM_BUFF); + i = (int)readlink (path, s, (size_t)COB_MEDIUM_MAX); + if (i > 0 && i < COB_MEDIUM_BUFF) { s[i] = 0; cobglobptr->cob_main_argv0 = cob_strdup (s); cob_free (s); @@ -10268,7 +10277,7 @@ void cob_set_main_argv0 (const int argc, char **argv) path = getexecname (); if (path) { #ifdef HAVE_REALPATH - s = cob_malloc ((size_t)COB_LARGE_BUFF); + s = cob_malloc ((size_t)COB_MEDIUM_BUFF); if (realpath (path, s) != NULL) { cobglobptr->cob_main_argv0 = cob_strdup (s); } else { @@ -10607,37 +10616,45 @@ cob_backtrace (void *target, int count) dump_trace_started ^= DUMP_TRACE_ACTIVE_TRACE; } -/* internal output the procedure stack entry to the given target */ -static void -output_procedure_stack_entry (const int file_no, +/* internal output the procedure stack entry to the given buffer, + returns the written length */ +static size_t +output_procedure_stack_entry (char *buff, const char *section, const char *paragraph, const char *source_file, const unsigned int source_line) { + size_t pos = 0; if (!section && !paragraph) { - return; + return 0; } - write_or_return_arr (file_no, "\n\t"); + + buff[pos++] = '\n'; + buff[pos++] = '\t'; if (section && paragraph) { - write_or_return_str (file_no, paragraph); - write_or_return_arr (file_no, " OF "); - write_or_return_str (file_no, section); + pos += strcat_to_buff (buff + pos, paragraph); + pos += strcat_to_buff (buff + pos, " OF "); + pos += strcat_to_buff (buff + pos, section); } else { if (section) { - write_or_return_str (file_no, section); + pos += strcat_to_buff (buff + pos, section); } else { - write_or_return_str (file_no, paragraph); + pos += strcat_to_buff (buff + pos, paragraph); } } - write_or_return_arr (file_no, " at "); - write_or_return_str (file_no, source_file); - write_or_return_arr (file_no, ":"); - write_or_return_int (file_no, (int)source_line); + pos += strcat_to_buff (buff + pos, " at "); + pos += strcat_to_buff (buff + pos, source_file); + buff[pos++] = ':'; + pos += intcat_to_buff (buff + pos, (int)source_line); + buff[pos] = '0'; + return pos; } /* internal output the COBOL-view of the stacktrace to the given target */ void cob_stack_trace_internal (FILE *target, int verbose, int count) { + char buff[COB_MEDIUM_BUFF]; + size_t pos = 0; cob_module *mod; int first_entry = 0; int i, k; @@ -10670,7 +10687,7 @@ cob_stack_trace_internal (FILE *target, int verbose, int count) } if (verbose) { - write_or_return_arr (file_no, "\n"); + buff[pos++] = '\n'; } k = 0; for (mod = COB_MODULE_PTR, i = 0; mod; mod = mod->next, i++) { @@ -10680,64 +10697,71 @@ cob_stack_trace_internal (FILE *target, int verbose, int count) if (count > 0 && count == i) { break; } - write_or_return_arr (file_no, " "); + buff[pos++] = ' '; if (mod->module_stmt != 0 && mod->module_sources) { const unsigned int source_file_num = COB_GET_FILE_NUM (mod->module_stmt); const unsigned int source_line = COB_GET_LINE_NUM (mod->module_stmt); const char *source_file = mod->module_sources[source_file_num]; if (!verbose) { - write_or_return_str (file_no, mod->module_name); - write_or_return_arr (file_no, " at "); - write_or_return_str (file_no, source_file); - write_or_return_arr (file_no, ":"); - write_or_return_int (file_no, (int)source_line); + pos += strcat_to_buff (buff + pos, mod->module_name); + pos += strcat_to_buff (buff + pos, " at "); + pos += strcat_to_buff (buff + pos, source_file); + buff[pos++] = ':'; + pos += intcat_to_buff (buff + pos, (int)source_line); } else if (mod->statement == STMT_UNKNOWN && !mod->section_name && !mod->paragraph_name) { /* GC 3.1 output, now used for "no source location / no trace" case */ - write_or_return_arr (file_no, "Last statement of "); + pos += strcat_to_buff (buff + pos, "Last statement of "); if (mod->module_type == COB_MODULE_TYPE_FUNCTION) { - write_or_return_arr (file_no, "FUNCTION "); + pos += strcat_to_buff (buff + pos, "FUNCTION "); } - write_or_return_arr (file_no, "\""); - write_or_return_str (file_no, mod->module_name); - write_or_return_arr (file_no, "\" was at line "); - write_or_return_int (file_no, (int)source_line); - write_or_return_arr (file_no, " of "); - write_or_return_str (file_no, source_file); + buff[pos++] = '"'; + pos += strcat_to_buff (buff + pos, mod->module_name); + pos += strcat_to_buff (buff + pos, "\" was at line "); + pos += intcat_to_buff (buff + pos, (int)source_line); + pos += strcat_to_buff (buff + pos, " of "); + pos += strcat_to_buff (buff + pos, source_file); } else if (!mod->section_name && !mod->paragraph_name) { /* special case: there _would_ be data, but there's no procedure defined in the program */ - write_or_return_arr (file_no, "Last statement of "); + pos += strcat_to_buff (buff + pos, "Last statement of "); if (mod->module_type == COB_MODULE_TYPE_FUNCTION) { - write_or_return_arr (file_no, "FUNCTION "); + pos += strcat_to_buff (buff + pos, "FUNCTION "); } - write_or_return_arr (file_no, "\""); - write_or_return_str (file_no, mod->module_name); - write_or_return_arr (file_no, "\" was "); - write_or_return_str (file_no, cob_statement_name[mod->statement]); - write_or_return_arr (file_no, " at line "); - write_or_return_int (file_no, (int)source_line); - write_or_return_arr (file_no, " of "); - write_or_return_str (file_no, source_file); + buff[pos++] = '"'; + pos += strcat_to_buff (buff + pos, mod->module_name); + pos += strcat_to_buff (buff + pos, "\" was "); + pos += strcat_to_buff (buff + pos, cob_statement_name[mod->statement]); + pos += strcat_to_buff (buff + pos, " at line "); + pos += intcat_to_buff (buff + pos, (int)source_line); + pos += strcat_to_buff (buff + pos, " of "); + pos += strcat_to_buff (buff + pos, source_file); } else { /* common case when compiled with runtime checks enabled: statement and procedure known - the later is printed from the stack entry with the source location by the following call */ - write_or_return_arr (file_no, "Last statement of "); + pos += strcat_to_buff (buff + pos, "Last statement of "); if (mod->module_type == COB_MODULE_TYPE_FUNCTION) { - write_or_return_arr (file_no, "FUNCTION "); + pos += strcat_to_buff (buff + pos, "FUNCTION "); } - write_or_return_arr (file_no, "\""); - write_or_return_str (file_no, mod->module_name); - write_or_return_arr (file_no, "\" was "); - write_or_return_str (file_no, cob_statement_name[mod->statement]); + buff[pos++] = '"'; + pos += strcat_to_buff (buff + pos, mod->module_name); + pos += strcat_to_buff (buff + pos, "\" was "); + pos += strcat_to_buff (buff + pos, cob_statement_name[mod->statement]); } - output_procedure_stack_entry (file_no, mod->section_name, mod->paragraph_name, + pos += output_procedure_stack_entry (buff + pos, + mod->section_name, mod->paragraph_name, source_file, source_line); + if (pos > COB_MEDIUM_MAX - COB_FILE_MAX) { + if (write_until_fail (file_no, buff, pos) == -1) { + return; + } + pos = 0; + } if (mod->frame_ptr) { struct cob_frame_ext *perform_ptr = mod->frame_ptr; int frame_max = 512; /* max from -fstack-size */ @@ -10748,71 +10772,92 @@ cob_stack_trace_internal (FILE *target, int verbose, int count) if (perform_ptr->section_name) { /* marker for "root frame" - at ENTRY */ if (perform_ptr->section_name[0] == 0) { - write_or_return_arr (file_no, "\n\tENTRY "); - write_or_return_str (file_no, perform_ptr->paragraph_name); - write_or_return_arr (file_no, " at "); - write_or_return_str (file_no, ffile); - write_or_return_arr (file_no, ":"); - write_or_return_int (file_no, (int)fline); + pos += strcat_to_buff (buff + pos, "\n\t" "ENTRY "); + pos += strcat_to_buff (buff + pos, perform_ptr->paragraph_name); + pos += strcat_to_buff (buff + pos, " at "); + pos += strcat_to_buff (buff + pos, ffile); + buff[pos++] = ':'; + pos += intcat_to_buff (buff + pos, (int)fline); break; } } - output_procedure_stack_entry (file_no, + pos += output_procedure_stack_entry (buff + pos, perform_ptr->section_name, perform_ptr->paragraph_name, ffile, fline); + if (pos > COB_MEDIUM_MAX - COB_FILE_MAX) { + if (write_until_fail (file_no, buff, pos) == -1) { + return; + } + pos = 0; + } perform_ptr--; } } } else { if (verbose) { - write_or_return_arr (file_no, "Last statement of "); + pos += strcat_to_buff (buff + pos, "Last statement of "); if (mod->module_type == COB_MODULE_TYPE_FUNCTION) { - write_or_return_arr (file_no, "FUNCTION "); + pos += strcat_to_buff (buff + pos, "FUNCTION "); } - write_or_return_arr (file_no, "\""); - write_or_return_str (file_no, mod->module_name); + buff[pos++] = '"'; + pos += strcat_to_buff (buff + pos, mod->module_name); if (mod->statement != STMT_UNKNOWN) { - write_or_return_arr (file_no, "\" was "); - write_or_return_str (file_no, cob_statement_name[mod->statement]); + pos += strcat_to_buff (buff + pos, "\" was "); + pos += strcat_to_buff (buff + pos, cob_statement_name[mod->statement]); } else { - write_or_return_arr (file_no, "\" unknown"); + pos += strcat_to_buff (buff + pos, "\" unknown"); } } else { - write_or_return_str (file_no, mod->module_name); - write_or_return_arr (file_no, " at unknown"); + pos += strcat_to_buff (buff + pos, mod->module_name); + pos += strcat_to_buff (buff + pos, " at unknown"); } } - write_or_return_arr (file_no, "\n"); + buff[pos++] = '\n'; if (mod->next == mod) { /* not translated as highly unexpected */ - write_or_return_arr (file_no, "FIXME: recursive mod (stack trace)\n"); + pos += strcat_to_buff (buff + pos, + "FIXME: recursive mod (stack trace)" "\n"); break; } if (k++ == MAX_MODULE_ITERS) { /* not translated as highly unexpected */ - write_or_return_arr (file_no, - "max module iterations exceeded, possible broken chain\n"); + pos += strcat_to_buff (buff + pos, + "max module iterations exceeded, possible broken chain" "\n"); break; } } if (mod) { - write_or_return_arr (file_no, " "); - write_or_return_str (file_no, more_stack_frames_msgid); - write_or_return_arr (file_no, "\n"); + buff[pos++] = ' '; + pos += strcat_to_buff (buff + pos, more_stack_frames_msgid); + buff[pos++] = '\n'; + } + if (pos > COB_MEDIUM_MAX - COB_FILE_MAX) { + if (write_until_fail (file_no, buff, pos) == -1) { + return; + } + pos = 0; } if (verbose && cob_argc != 0) { - size_t ia; - write_or_return_arr (file_no, " Started by "); - write_or_return_str (file_no, cob_argv[0]); - write_or_return_arr (file_no, "\n"); - for (ia = 1; ia < (size_t)cob_argc; ++ia) { - write_or_return_arr (file_no, "\t"); - write_or_return_str (file_no, cob_argv[ia]); - write_or_return_arr (file_no, "\n"); + const unsigned int ia_max = (unsigned int)cob_argc; + unsigned int ia; + pos += strcat_to_buff (buff + pos, " Started by "); + pos += strcat_to_buff (buff + pos, cob_argv[0]); + buff[pos++] = '\n'; + for (ia = 1; ia < ia_max; ++ia) { + buff[pos++] = '\t'; + pos += strcat_to_buff (buff + pos, cob_argv[ia]); + buff[pos++] = '\n'; + if (pos > COB_MEDIUM_MAX - COB_FILE_MAX) { + if (write_until_fail (file_no, buff, pos) == -1) { + return; + } + pos = 0; + } } } + write_until_fail (file_no, buff, pos); } FILE * @@ -10923,6 +10968,7 @@ cob_dump_module (char *reason) fputc ('\n', fp); fprintf (fp, _("Module dump due to %s"), reason); fputc ('\n', fp); + fflush (fp); } if (fp != stdout) { /* was already sent to stderr before this function was called, @@ -10933,7 +10979,6 @@ cob_dump_module (char *reason) dump_trace_started ^= DUMP_TRACE_ACTIVE_TRACE; } } - fflush (stdout); } else { fflush (stderr); } diff --git a/libcob/fileio.c b/libcob/fileio.c index f5bbc61cf..936c42f24 100644 --- a/libcob/fileio.c +++ b/libcob/fileio.c @@ -20,6 +20,7 @@ #include "config.h" +#include "libcob/common.h" #define _LFS64_LARGEFILE 1 #define _LFS64_STDIO 1 @@ -8768,7 +8769,6 @@ cob_get_filename_print (cob_file* file, const int show_resolved_name) cobsetpr-values with type ENV_PATH or ENV_STR like bdb_home and cob_file_path are taken care in cob_exit_common()! */ - const char *implicit_close_of_msgid = NULL; void @@ -8777,7 +8777,8 @@ cob_exit_fileio_msg_only (void) struct file_list *l; static int output_done = 0; - if (output_done) { + if (output_done + || (cobsetptr && !cobsetptr->cob_display_warn)) { return; } output_done = 1; @@ -8788,8 +8789,10 @@ cob_exit_fileio_msg_only (void) && l->file->open_mode != COB_OPEN_LOCKED && !l->file->flag_nonexistent && !COB_FILE_SPECIAL (l->file)) { - cob_runtime_warning_ss (implicit_close_of_msgid, - cob_get_filename_print (l->file, 0)); + if (cob_runtime_warning_ss (implicit_close_of_msgid, + cob_get_filename_print (l->file, 0))) { + return; + } } } } From ca09f172185ffbfa821a01030c9a873e26d8dff1 Mon Sep 17 00:00:00 2001 From: sf-mensch Date: Fri, 4 Oct 2024 15:38:31 +0000 Subject: [PATCH 07/29] minor testuite update to drop user-reported warnings from compiler/linker --- tests/testsuite.src/listings.at | 10 ++- tests/testsuite.src/run_file.at | 8 +- tests/testsuite.src/run_misc.at | 125 +++++++++++++++------------ tests/testsuite.src/syn_functions.at | 5 +- 4 files changed, 85 insertions(+), 63 deletions(-) diff --git a/tests/testsuite.src/listings.at b/tests/testsuite.src/listings.at index 2a2fb68a6..26d90b67e 100644 --- a/tests/testsuite.src/listings.at +++ b/tests/testsuite.src/listings.at @@ -6913,7 +6913,8 @@ AT_CLEANUP AT_SETUP([Long concatenated literal]) AT_KEYWORDS([listing overflow]) -AT_DATA([prog.cob], [ +# extra quoting here as we received a bug report of something adding a leading ( +AT_DATA([prog.cob], [[ >>SOURCE FORMAT IS FREE ID DIVISION. PROGRAM-ID. ED000MAIN IS INITIAL. @@ -6935,10 +6936,11 @@ WORKING-STORAGE SECTION. "1234567890123456789012". PROCEDURE DIVISION. EXIT. -]) +]]) +# extra quoting here as we received a bug report of something adding a leading ( AT_CHECK([$COMPILE_LISTING0 -t- prog.cob], [0], -[GnuCOBOL V.R.P prog.cob +[[GnuCOBOL V.R.P prog.cob LINE PG/LN A...B............................................................ @@ -6980,7 +6982,7 @@ LINE PG/LN A...B............................................................ 0 warnings in compilation group 0 errors in compilation group -]) +]]) AT_CLEANUP diff --git a/tests/testsuite.src/run_file.at b/tests/testsuite.src/run_file.at index 2aed60f08..f7fbbfe8c 100644 --- a/tests/testsuite.src/run_file.at +++ b/tests/testsuite.src/run_file.at @@ -9102,7 +9102,6 @@ TSTFH (unsigned char *opCodep, FCD3 *fcd) static char * /* Return Text name of function */ txtOpCode(int opCode) { - static char tmp[32]; switch (opCode) { case OP_OPEN_INPUT: return "OPEN_IN"; case OP_OPEN_OUTPUT: return "OPEN_OUT"; @@ -9154,8 +9153,11 @@ txtOpCode(int opCode) case OP_WRITE_AFTER_TAB: return "WRITE_AFTER_TAB"; case OP_WRITE_AFTER_PAGE: return "WRITE_AFTER_PAGE"; } - sprintf(tmp, "Func 0x%02X:", opCode); - return tmp; + { + static char wrk[20]; + snprintf (wrk, sizeof(wrk), "Func 0x%02X", opCode); + return wrk; + } } ]]) diff --git a/tests/testsuite.src/run_misc.at b/tests/testsuite.src/run_misc.at index 914a8f4a1..cd7cf27e6 100644 --- a/tests/testsuite.src/run_misc.at +++ b/tests/testsuite.src/run_misc.at @@ -11866,7 +11866,6 @@ AT_DATA([cmod.c], [[ static char * getType (int type, int byvalue) { - static char wrk[24]; switch (type) { #if 1 case COB_TYPE_GROUP: return "Group"; @@ -11897,28 +11896,30 @@ getType (int type, int byvalue) case COB_TYPE_NATIONAL: return "N"; #endif } - sprintf (wrk,"Type %04X",type); - return wrk; + { + static char wrk[20]; + snprintf (wrk, sizeof(wrk), "Type 0x%04X", type); + return wrk; + } } COB_EXT_EXPORT int CAPI (void *p1, ...) { - int k,nargs,type,digits,scale,size,sign,byvalue; - cob_s64_t val = 0; - char *str; - char wrk[80],pic[30]; /* note: maximum _theoretical_ size */ + char wrk[80], pic[30]; /* note: maximum _theoretical_ size */ + const int nargs = cob_get_num_params(); + int k; + cob_s64_t val = 0; - nargs = cob_get_num_params(); printf ("CAPI called with %d parameters\n",nargs); - fflush(stdout); + fflush (stdout); for (k=1; k <= nargs; k++) { - type = cob_get_param_type (k); - digits = cob_get_param_digits (k); - scale = cob_get_param_scale (k); - size = cob_get_param_size (k); - sign = cob_get_param_sign (k); - byvalue = cob_get_param_constant(k); + int type = cob_get_param_type (k); + int digits = cob_get_param_digits (k); + int scale = cob_get_param_scale (k); + int size = cob_get_param_size (k); + int sign = cob_get_param_sign (k); + int byvalue = cob_get_param_constant(k); printf (" %d: %-8s ", k, getType (type, byvalue)); if (byvalue) { printf ("BY VALUE "); @@ -11926,27 +11927,31 @@ CAPI (void *p1, ...) printf ("BY REFERENCE "); } if (type == COB_TYPE_ALPHANUMERIC) { - sprintf (pic, "X(%d)", size); - str = cob_get_picx_param (k, NULL, 0); + char *str = cob_get_picx_param (k, NULL, 0); + snprintf (pic, sizeof(pic), "X(%d)", size); printf ("%-11s '%s'", pic, str); cob_free ((void*)str); cob_put_picx_param (k, "Bye!"); } else if (type == COB_TYPE_NATIONAL) { - sprintf (pic, "N(%d)", size); /* FIXME */ + snprintf (pic, sizeof(pic), "N(%d)", size); /* FIXME */ printf ("exchange of national data is not supported yet"); } else if (type == COB_TYPE_GROUP) { - sprintf (pic, "(%d)", size); - str = cob_get_grp_param (k, NULL, 0); + char *str = cob_get_grp_param (k, NULL, 0); + snprintf (pic, sizeof(pic), "(%d)", size); printf ("%-11s '%.*s'", pic, size, str); cob_free ((void*)str); - memset (wrk,' ',sizeof(wrk)); - memcpy (wrk,"Bye-Bye Birdie!",15); + memset (wrk, ' ',sizeof(wrk)); + memcpy (wrk, "Bye-Bye Birdie!", 15); cob_put_grp_param (k, wrk, sizeof(wrk)); } else if (type == COB_TYPE_NUMERIC_EDITED) { if (scale > 0) { - sprintf (pic,"%s9(%d)V9(%d)",sign?"S":"",digits-scale,scale); + snprintf (pic, sizeof(pic), "%s9(%d)V9(%d)", + sign ? "S":"", + digits - scale, scale); } else { - sprintf (pic,"%s9(%d)",sign?"S":"",digits-scale); + snprintf (pic, sizeof(pic), "%s9(%d)", + sign ? "S":"", + digits - scale); } val = cob_get_s64_param (k); printf ("%-11s %lld ",pic,val); @@ -11957,9 +11962,13 @@ CAPI (void *p1, ...) printf (" to %.*s",size,wrk); } else { if(scale > 0) { - sprintf (pic,"%s9(%d)V9(%d)",sign?"S":"",digits-scale,scale); + snprintf (pic, sizeof(pic), "%s9(%d)V9(%d)", + sign ? "S":"", + digits - scale, scale); } else { - sprintf (pic,"%s9(%d)",sign?"S":"",digits-scale); + snprintf (pic, sizeof(pic), "%s9(%d)", + sign ? "S":"", + digits - scale); } val = cob_get_s64_param (k); printf ("%-11s %lld", pic, val); @@ -12046,7 +12055,7 @@ AT_CLEANUP AT_SETUP([C-API (field based)]) -AT_KEYWORDS([runmisc CALL api]) +AT_KEYWORDS([runmisc CALL api field]) AT_DATA([prog.cob], [ IDENTIFICATION DIVISION. @@ -12102,7 +12111,6 @@ AT_DATA([cmod.c], [[ static char * getType (int type, int byvalue) { - static char wrk[24]; switch (type) { #if 1 case COB_TYPE_GROUP: return "Group"; @@ -12133,73 +12141,82 @@ getType (int type, int byvalue) case COB_TYPE_NATIONAL: return "N"; #endif } - sprintf (wrk,"Type %04X",type); - return wrk; + { + static char wrk[20]; + snprintf (wrk, sizeof(wrk), "Type 0x%04X", type); + return wrk; + } } COB_EXT_EXPORT int CAPI (void *p1, ...) { - int k,nargs,type,digits,scale,size,sign,byvalue; - cob_s64_t val; - char *str; - char wrk[80],pic[30]; /* note: maximum _theoretical_ size */ + char wrk[80],pic[30]; /* note: maximum _theoretical_ size */ + const int nargs = cob_get_num_params(); + int k; - nargs = cob_get_num_params(); printf ("CAPI called with %d parameters\n",nargs); - fflush(stdout); + fflush (stdout); for (k=1; k <= nargs; k++) { cob_field *fld = cob_get_param_field (k, "CAPI"); - type = cob_get_field_type (fld); - digits = cob_get_field_digits (fld); - scale = cob_get_field_scale (fld); - size = cob_get_field_size (fld); - sign = cob_get_field_sign (fld); - byvalue = cob_get_field_constant (fld); + char *str = (char *) cob_get_field_str_buffered (fld); + int type = cob_get_field_type (fld); + int digits = cob_get_field_digits (fld); + int scale = cob_get_field_scale (fld); + int size = cob_get_field_size (fld); + int sign = cob_get_field_sign (fld); + int byvalue = cob_get_field_constant (fld); printf (" %d: %-8s ", k, getType (type, byvalue)); if (byvalue) { printf ("BY VALUE "); } else { printf ("BY REFERENCE "); } - str = (char *) cob_get_field_str_buffered (fld); if (type == COB_TYPE_ALPHANUMERIC) { - sprintf (pic, "X(%d)", size); + snprintf (pic, sizeof(pic), "X(%d)", size); printf ("%-11s '%s'", pic, str); cob_put_field_str (fld, "Bye!"); } else if (type == COB_TYPE_NATIONAL) { - sprintf (pic,"N(%d)",size); /* FIXME */ + snprintf (pic, sizeof(pic), "N(%d)", size); /* FIXME */ printf ("exchange of national data is not supported yet"); } else if (type == COB_TYPE_GROUP) { - sprintf (pic,"(%d)",size); + snprintf (pic, sizeof(pic), "(%d)",size); printf ("%-11s '%.*s'",pic,size,str); cob_put_field_str (fld, "Bye-Bye Birdie!"); } else if (type == COB_TYPE_NUMERIC_EDITED) { + cob_s64_t val = cob_get_s64_param (k); if (scale > 0) { - sprintf (pic,"%s9(%d)V9(%d)",sign?"S":"",digits-scale,scale); + snprintf (pic, sizeof(pic), "%s9(%d)V9(%d)", + sign ? "S":"", + digits - scale, scale); } else { - sprintf (pic,"%s9(%d)",sign?"S":"",digits-scale); + snprintf (pic, sizeof(pic), "%s9(%d)", + sign ? "S":"", + digits - scale); } printf ("%-11s %s ",pic,str); - val = cob_get_s64_param (k); val = val + 130; val = -val; cob_put_s64_param (k, val); str = (char *) cob_get_field_str (fld, wrk, 78); printf (" to %.*s",size,wrk); } else { + cob_s64_t val = cob_get_s64_param (k); if(scale > 0) { - sprintf (pic,"%s9(%d)V9(%d)",sign?"S":"",digits-scale,scale); + snprintf (pic, sizeof(pic), "%s9(%d)V9(%d)", + sign ? "S":"", + digits - scale, scale); } else { - sprintf (pic,"%s9(%d)",sign?"S":"",digits-scale); + snprintf (pic, sizeof(pic), "%s9(%d)", + sign ? "S":"", + digits - scale); } printf ("%-11s %s", pic, str); - val = cob_get_s64_param (k); - sprintf (wrk, "%lld", val + 3); + snprintf (wrk, sizeof(wrk), "%lld", val + 3); cob_put_field_str (fld, wrk); } printf (";\n"); - fflush(stdout); + fflush (stdout); } return 0; } diff --git a/tests/testsuite.src/syn_functions.at b/tests/testsuite.src/syn_functions.at index 53735c571..27f3e2773 100644 --- a/tests/testsuite.src/syn_functions.at +++ b/tests/testsuite.src/syn_functions.at @@ -582,10 +582,11 @@ AT_DATA([prog.cob], [ . ]) +# extra quoting here as we received a bug report of something adding a leading ( AT_CHECK([$COMPILE -Wno-pending prog.cob], [1], [], -[prog.cob:7: error: syntax error, unexpected Literal, expecting PHYSICAL or ) +[[prog.cob:7: error: syntax error, unexpected Literal, expecting PHYSICAL or ) prog.cob:8: error: a non-numeric literal is expected here prog.cob:9: error: a non-numeric literal is expected here -]) +]]) AT_CLEANUP From ef11be499f4c6f2a3f6907443d54590e1db6f659 Mon Sep 17 00:00:00 2001 From: sf-mensch Date: Fri, 4 Oct 2024 15:53:21 +0000 Subject: [PATCH 08/29] fix previous commit --- libcob/common.c | 1 - libcob/fileio.c | 1 - 2 files changed, 2 deletions(-) diff --git a/libcob/common.c b/libcob/common.c index cfc30f39f..828762145 100644 --- a/libcob/common.c +++ b/libcob/common.c @@ -18,7 +18,6 @@ along with GnuCOBOL. If not, see . */ -#include "libcob/common.h" #include "tarstamp.h" #include "config.h" diff --git a/libcob/fileio.c b/libcob/fileio.c index 936c42f24..509623452 100644 --- a/libcob/fileio.c +++ b/libcob/fileio.c @@ -20,7 +20,6 @@ #include "config.h" -#include "libcob/common.h" #define _LFS64_LARGEFILE 1 #define _LFS64_STDIO 1 From 83ec07716d30732e050c0b6b96ecf5b462045e21 Mon Sep 17 00:00:00 2001 From: sf-mensch Date: Fri, 4 Oct 2024 18:42:50 +0000 Subject: [PATCH 09/29] portability fix for last commits --- libcob/common.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/libcob/common.c b/libcob/common.c index 828762145..00c5d9a40 100644 --- a/libcob/common.c +++ b/libcob/common.c @@ -1021,7 +1021,7 @@ set_source_location (const char **file, unsigned int *line) /* writes data to fd, returns either the initial size or -1 in case of error */ static COB_INLINE cob_s64_t -write_until_fail (int fd, const void *data, size_t size) +write_until_fail (int fd, const char *data, size_t size) { register cob_s64_t size_to_write = size; while (size_to_write > 0) { From b583a357302ad882fd2ac6565f823d9750b46e37 Mon Sep 17 00:00:00 2001 From: sf-mensch Date: Tue, 8 Oct 2024 23:37:24 +0000 Subject: [PATCH 10/29] build and test updates * configure: check expected json-c header first * tests: * atlocal.in, atlocal_win: export new definition COB_ON_WINDOWS to allow the testsuite skipping/failing tests - and applied it to used_binaries.at * run_prog_manual.sh.in: fix extranous $COBCRUN for all test runners * run_prog_manual.sh.in (xterm): use all parameters, not only the first * build_windows/set_env_vs_dist: supporting space-included paths (not recommended) --- build_windows/ChangeLog.txt | 8 ++++++-- build_windows/set_env_vs_x64.cmd | 4 ++-- build_windows/set_env_vs_x64.dist.tmpl.cmd | 4 ++-- build_windows/set_env_vs_x86.cmd | 4 ++-- build_windows/set_env_vs_x86.dist.tmpl.cmd | 2 +- configure.ac | 2 +- tests/ChangeLog | 7 +++++++ tests/atlocal.in | 18 +++++++++++++----- tests/atlocal_win | 3 +++ tests/run_prog_manual.sh.in | 8 ++++---- tests/testsuite.src/used_binaries.at | 12 ++++++++---- 11 files changed, 49 insertions(+), 23 deletions(-) diff --git a/build_windows/ChangeLog.txt b/build_windows/ChangeLog.txt index a4b7b78dc..9eba7e07d 100644 --- a/build_windows/ChangeLog.txt +++ b/build_windows/ChangeLog.txt @@ -1,4 +1,8 @@ +2024-10-07 Simon Sobisch + + * set_env_vs_dist: supporting space-included paths (not recommended) + 2024-05-15 Simon Sobisch * makedist.cmd: cater for new different library names @@ -315,7 +319,7 @@ * update for subfolder vc10 -2014-07-07 Philipp Böhme +2014-07-07 Philipp B�hme * minor bugfix (tpyos) for subfolder vc12 @@ -326,7 +330,7 @@ * updated all project files * added subfolder vc11 -2014-06-20 Philipp Böhme +2014-06-20 Philipp B�hme * added project files - subfolders: vc7, vc8, vc9, vc10, vc12 (original project files and resource files version_cobc.rc, diff --git a/build_windows/set_env_vs_x64.cmd b/build_windows/set_env_vs_x64.cmd index 4fde7ca57..4c905c9f3 100644 --- a/build_windows/set_env_vs_x64.cmd +++ b/build_windows/set_env_vs_x64.cmd @@ -1,4 +1,4 @@ -:: Copyright (C) 2014-2020 Free Software Foundation, Inc. +:: Copyright (C) 2014-2020,2024 Free Software Foundation, Inc. :: Written by Simon Sobisch, Edward Hart :: :: This file is part of GnuCOBOL. @@ -36,4 +36,4 @@ if %errorlevel% equ 0 ( set "stay_open=x" ) -call %~dp0gcvsvars.cmd %* +call "%~dp0gcvsvars.cmd" %* diff --git a/build_windows/set_env_vs_x64.dist.tmpl.cmd b/build_windows/set_env_vs_x64.dist.tmpl.cmd index 6c5dd8e68..31afef62b 100644 --- a/build_windows/set_env_vs_x64.dist.tmpl.cmd +++ b/build_windows/set_env_vs_x64.dist.tmpl.cmd @@ -1,4 +1,4 @@ -:: Copyright (C) 2014-2020 Free Software Foundation, Inc. +:: Copyright (C) 2014-2020,2024 Free Software Foundation, Inc. :: Written by Simon Sobisch, Edward Hart :: :: This file is part of GnuCOBOL. @@ -36,4 +36,4 @@ if %errorlevel% equ 0 ( set "stay_open=x" ) -call %~dp0gcvsvars.cmd %* +call "%~dp0gcvsvars.cmd" %* diff --git a/build_windows/set_env_vs_x86.cmd b/build_windows/set_env_vs_x86.cmd index c80706ba6..8fc7e2007 100644 --- a/build_windows/set_env_vs_x86.cmd +++ b/build_windows/set_env_vs_x86.cmd @@ -1,4 +1,4 @@ -:: Copyright (C) 2014-2020 Free Software Foundation, Inc. +:: Copyright (C) 2014-2020,2024 Free Software Foundation, Inc. :: Written by Simon Sobisch, Edward Hart :: :: This file is part of GnuCOBOL. @@ -39,4 +39,4 @@ if %errorlevel% equ 0 ( set "stay_open=x" ) -call %~dp0gcvsvars.cmd %* +call "%~dp0gcvsvars.cmd" %* diff --git a/build_windows/set_env_vs_x86.dist.tmpl.cmd b/build_windows/set_env_vs_x86.dist.tmpl.cmd index e8e01d7f6..4a160b87d 100644 --- a/build_windows/set_env_vs_x86.dist.tmpl.cmd +++ b/build_windows/set_env_vs_x86.dist.tmpl.cmd @@ -36,4 +36,4 @@ if %errorlevel% equ 0 ( set "stay_open=x" ) -call %~dp0gcvsvars.cmd %* +call "%~dp0gcvsvars.cmd" %* diff --git a/configure.ac b/configure.ac index 126e2a363..703d359b2 100644 --- a/configure.ac +++ b/configure.ac @@ -1222,7 +1222,7 @@ AS_IF([test "$USE_JSON" = "json-c" -o "$USE_JSON" = check], [ JSON_C_LIBS="-ljson-c" fi LIBS="$LIBS $LIBCOB_LIBS_extern $JSON_C_LIBS" - AC_CHECK_HEADERS([json.h json-c/json.h], [break], + AC_CHECK_HEADERS([json-c/json.h json.h], [break], [if test "$with_json" = "json-c"; then AC_MSG_ERROR([header for libjson-c is required for --with-json=json-c, you may adjust JSON_C_CFLAGS]) else diff --git a/tests/ChangeLog b/tests/ChangeLog index b99d0ba74..29e095b7f 100644 --- a/tests/ChangeLog +++ b/tests/ChangeLog @@ -1,4 +1,11 @@ +2024-10-05 Simon Sobisch + + * atlocal.in, atlocal_win: export new definition COB_ON_WINDOWS + to allow the testsuite skipping/failing tests + * run_prog_manual.sh.in: fix extranous $COBCRUN for all test runners + * run_prog_manual.sh.in (xterm): use all parameters, not only the first + 2024-10-02 Simon Sobisch * atlocal.in, atlocal_win: allow overriding COB_CC during tests diff --git a/tests/atlocal.in b/tests/atlocal.in index d2f0a4429..254e08e59 100644 --- a/tests/atlocal.in +++ b/tests/atlocal.in @@ -225,11 +225,19 @@ set_utf8_locale () { } # ensure we don't execute windows paths within programs generated by cygwin -# by passing a hint -if test "$OSTYPE" = "cygwin"; then - COB_ON_CYGWIN=1 - export COB_ON_CYGWIN -fi +# by passing a hint and to (not) skip some tests that are portable in all +# environments but Windows +case "$OSTYPE" in + msys*|win* ) + # Windows but not Cygwin + COB_ON_WINDOWS=yes + export COB_ON_WINDOWS + ;; + cygwin* ) + COB_ON_CYGWIN=yes + export COB_ON_CYGWIN + ;; +esac # Fix for testcases where cobc translates path to win32 equivalents if test "x$MSYSTEM" != "x"; then diff --git a/tests/atlocal_win b/tests/atlocal_win index 8cf1e85cf..3cdb892d4 100644 --- a/tests/atlocal_win +++ b/tests/atlocal_win @@ -125,6 +125,9 @@ set_utf8_locale () { # Note: we explicit do not set COB_ON_CYGWIN here, # as this is file is about running non-cygwin binaries + # Windows but not Cygwin + COB_ON_WINDOWS=1 + export COB_ON_WINDOWS # Fix for testcases where cobc uses win32 paths internally PATHSEP=";" diff --git a/tests/run_prog_manual.sh.in b/tests/run_prog_manual.sh.in index aad4f79f2..dd063596e 100755 --- a/tests/run_prog_manual.sh.in +++ b/tests/run_prog_manual.sh.in @@ -69,7 +69,7 @@ TITLE="GnuCOBOL Manual Test Run - $DESC" _test_with_xterm () { xterm -T "$TITLE" \ -fa 'Liberation Mono' -fs 14 \ - -e "sh -c \"(\$COBCRUN_DIRECT $1 2>./syserr.log && echo \$? > ./result) || echo 1 > ./result\"" + -e "sh -c \"(\$* 2>./syserr.log && echo \$? > ./result) || echo 1 > ./result\"" } @@ -92,7 +92,7 @@ _test_with_screen () { fi # run actual test in screen session screen -S "GCTESTS" -X title "$TITLE" - screen -S "GCTESTS" -X exec ... sh -c "cd \"$PWD\" && ($COBCRUN_DIRECT $* 2>./syserr.log && echo $? > ./result) || echo 1 > ./result" + screen -S "GCTESTS" -X exec ... sh -c "cd \"$PWD\" && ($* 2>./syserr.log && echo $? > ./result) || echo 1 > ./result" } _attach_to_screen () { test -d "$SCREENDIR" && (screen -r "GCTESTS" ; true) && exit @@ -119,7 +119,7 @@ _test_with_tmux () { fi # run actual test in screen session tmux rename-window -t "=GCTESTS:0" "$TITLE" - tmux send-keys -t "=GCTESTS:0" "sh -c \"cd \\\"$PWD\\\" && ($COBCRUN_DIRECT $* 2>./syserr.log && echo $? > ./result) || echo 1 > ./result; echo\"" C-m + tmux send-keys -t "=GCTESTS:0" "sh -c \"cd \\\"$PWD\\\" && ($* 2>./syserr.log && echo $? > ./result) || echo 1 > ./result; echo\"" C-m } _attach_to_tmux () { tmux attach -t "=GCTESTS:0" @@ -133,7 +133,7 @@ _kill_tmux () { _test_with_cmd () { # run cmd to start a detached cmd (via cmd's start), and execute the tests there, # to work around quoting issues we create a sub-cmd - echo "$COBCRUN_DIRECT $(echo $* | tr '/' '\\') 2>syserr.log & echo !errorlevel! >result" > run_manual.cmd + echo "$(echo $* | tr '/' '\\') 2>syserr.log & echo !errorlevel! >result" > run_manual.cmd cmd.exe /c "start \"$TITLE\" /wait cmd /v:on /c run_manual.cmd" #if test -f ./syserr.log; then # dos2unix -q ./syserr.log diff --git a/tests/testsuite.src/used_binaries.at b/tests/testsuite.src/used_binaries.at index 0e200a960..405c48d0f 100644 --- a/tests/testsuite.src/used_binaries.at +++ b/tests/testsuite.src/used_binaries.at @@ -359,9 +359,8 @@ AT_CLEANUP AT_SETUP([temporary path invalid]) AT_KEYWORDS([cobc runmisc]) -# Note: may be either removed completely as there was a report about -# this test "failing" - or skipped as this very often fails for -# WIN32 builds +# Note: we skip this as it often fails for WIN32 builds but sometimes works +AT_SKIP_IF([test "$COB_ON_WINDOWS" = "yes"]) AT_DATA([prog.cob], [ IDENTIFICATION DIVISION. @@ -1379,7 +1378,7 @@ AT_DATA([prog.cob], [ ]) AT_CHECK([$COMPILE prog.cob], [0], [], []) -AT_CHECK([$COBCRUN_DIRECT ./prog| head -n 2], [0], +AT_CHECK([$COBCRUN_DIRECT ./prog | head -n 2], [0], [1 2 ], []) @@ -1390,6 +1389,11 @@ AT_CLEANUP AT_SETUP([signal handling SIGTERM in COBOL]) AT_KEYWORDS([runmisc stack stacktrace]) +# this is portable in all posix environments, but not on Win32; +# note: cygwin-compiled programs handle cygwin-sent SIGTERM as expected +# CTRL+C does raise a SIGINT, but only when executed from "within" the program +AT_XFAIL_IF([test "$COB_ON_WINDOWS" = "yes"]) + AT_DATA([prog.cob], [ IDENTIFICATION DIVISION. PROGRAM-ID. 'prog'. From 190139b8baee6e0d08f69ef57dc9c303e7d8a47c Mon Sep 17 00:00:00 2001 From: sf-mensch Date: Fri, 11 Oct 2024 19:43:32 +0000 Subject: [PATCH 11/29] follow-up to r5356 - fixed skip via atlocal_win --- tests/atlocal_win | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/tests/atlocal_win b/tests/atlocal_win index 3cdb892d4..b24ff2d7e 100644 --- a/tests/atlocal_win +++ b/tests/atlocal_win @@ -126,7 +126,7 @@ set_utf8_locale () { # Note: we explicit do not set COB_ON_CYGWIN here, # as this is file is about running non-cygwin binaries # Windows but not Cygwin - COB_ON_WINDOWS=1 + COB_ON_WINDOWS=yes export COB_ON_WINDOWS # Fix for testcases where cobc uses win32 paths internally From 0cc8207d14de2633fb80ebd790dc929e4be76f13 Mon Sep 17 00:00:00 2001 From: sf-mensch Date: Fri, 11 Oct 2024 19:43:32 +0000 Subject: [PATCH 12/29] follow-up to r5356 - fixed skip via atlocal_win --- tests/atlocal_win | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/tests/atlocal_win b/tests/atlocal_win index 3cdb892d4..b24ff2d7e 100644 --- a/tests/atlocal_win +++ b/tests/atlocal_win @@ -126,7 +126,7 @@ set_utf8_locale () { # Note: we explicit do not set COB_ON_CYGWIN here, # as this is file is about running non-cygwin binaries # Windows but not Cygwin - COB_ON_WINDOWS=1 + COB_ON_WINDOWS=yes export COB_ON_WINDOWS # Fix for testcases where cobc uses win32 paths internally From ac862070c3e821e6c451e3f08e70882a17d271b4 Mon Sep 17 00:00:00 2001 From: chaat Date: Thu, 24 Oct 2024 06:08:36 +0000 Subject: [PATCH 13/29] fixed [bugs:#999] ACCEPT with TIMEOUT issue when looping thru the verb libcob/screenio.c (cob_screen_get_all): directly position to the cursor position within the field according to CURSOR clause --- libcob/ChangeLog | 6 + libcob/screenio.c | 3 + tests/testsuite.src/run_manual_screen.at | 146 +++++++++++++++++++++++ 3 files changed, 155 insertions(+) diff --git a/libcob/ChangeLog b/libcob/ChangeLog index 8b440116e..92f1b255b 100644 --- a/libcob/ChangeLog +++ b/libcob/ChangeLog @@ -1,4 +1,10 @@ +2024-10-22 Chuck Haatvedt + + * screenio.c (cob_screen_get_all): fixed Bug #999 + directly position to the cursor position within the + field according to CURSOR clause + 2024-10-04 Simon Sobisch * common.c (cob_sig_handler): moved call of cob_exit_screen_from_signal diff --git a/libcob/screenio.c b/libcob/screenio.c index e0512cc19..5d70cd474 100644 --- a/libcob/screenio.c +++ b/libcob/screenio.c @@ -2425,6 +2425,9 @@ cob_screen_get_all (const int initial_curs, const int accept_timeout) if (fld_index >= 0) { curr_index = fld_index; SET_FLD_AND_DATA_REFS (curr_index, sptr, s, sline, scolumn, right_pos, p); + if (scolumn != cursor_clause_col) { + p += cursor_clause_col - scolumn; + } at_eof = 0; cob_screen_attr (s->foreg, s->backg, s->attr, NULL, NULL, ACCEPT_STATEMENT); cob_move_cursor (cursor_clause_line, cursor_clause_col); diff --git a/tests/testsuite.src/run_manual_screen.at b/tests/testsuite.src/run_manual_screen.at index a5ed5cb19..2c6596b7d 100644 --- a/tests/testsuite.src/run_manual_screen.at +++ b/tests/testsuite.src/run_manual_screen.at @@ -3667,3 +3667,149 @@ MANUAL_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) AT_CLEANUP + +AT_SETUP([ACCEPT SCREEN TIMEOUT]) +AT_KEYWORDS([crt status cursor]) + +AT_SKIP_IF([test "$COB_HAS_CURSES" != "yes"]) + +AT_DATA([prog.cob], [ + REPLACE ==:BCOL:== BY ==BACKGROUND-COLOR==; ==:FCOL:== BY + ==FOREGROUND-COLOR==. + ** ************************************************************* + ** + ** ************************************************************* + IDENTIFICATION DIVISION. + PROGRAM-ID. PROG. + * GnuCOBOL sample + ENVIRONMENT DIVISION. + CONFIGURATION SECTION. + SPECIAL-NAMES. + CRT STATUS IS WCRT-STATUS. + CURSOR IS WCURSORROWCOL. + DATA DIVISION. + + WORKING-STORAGE SECTION. + 77 K-ENTER PIC 9(04) VALUE 0000. + 77 K-TIMEOUT PIC 9(04) VALUE 8001. + + 01 WCRT-STATUS PIC 9(04) VALUE ZERO. + 01 WCURSORROWCOL PIC 9(06) VALUE 000000. + 01 REDEFINES WCURSORROWCOL . + 05 WCURSORROW PIC 9(03). + 05 WCURSORCOL PIC 9(03). + 01 BLACK CONSTANT AS 00. + 01 BLUE CONSTANT AS 01. + 01 GREEN CONSTANT AS 02. + 01 CYAN CONSTANT AS 03. + 01 RED CONSTANT AS 04. + 01 MAGENTA CONSTANT AS 05. + * old color code as yellow + 01 BROWN CONSTANT AS 06. + * or Light Gray + 01 WHITE CONSTANT AS 07. + * or Dark Gray + 01 GREY CONSTANT AS 08. + * same color code as Grey + 01 LIGHTBLACK CONSTANT AS 08. + 01 LIGHTBLUE CONSTANT AS 09. + 01 LIGHTGREEN CONSTANT AS 10. + 01 LIGHTCYAN CONSTANT AS 11. + 01 LIGHTRED CONSTANT AS 12. + 01 LIGHTMAGENTA CONSTANT AS 13. + 01 PINK CONSTANT AS 13. + 01 YELLOW CONSTANT AS 14. + 01 LIGHTWHITE CONSTANT AS 15. + + + + 01 W-VAR-SELECTION. + 02 W-DATA PIC X(8). + 02 W-REPLY PIC X(01). + 88 SUCCESS VALUE 'Y', 'y'. + + + SCREEN SECTION. + + 01 SCREEN-SELECTION. + 02 LINE 06 COL 05 :FCOL: BLACK :BCOL: CYAN + VALUE 'TIMEOUT TEST - ENTER 4 CHARACTERS OF DATA' & + ' AND PAUSE UNTIL TIME CHANGES'. + 02 LINE 07 COL 05 :FCOL: BLACK :BCOL: CYAN + VALUE ' THEN ENTER 4 MORE CHARACTERS OF DATA' & + ' AND PAUSE UNTIL TIME CHANGES'. + 02 LINE 08 COL 05 :FCOL: BLACK :BCOL: CYAN + VALUE ' THEN AFTER THE TIME CHANGES ' & + ' ENTER A Y IN THE REPY LINE IF THE DATA ' & + ' IS CORRECT'. + + 02 LINE 15 COL 20 VALUE 'Data Entry:'. + 02 LINE + 2 COL 20 VALUE 'Reply:'. + 02 LINE 15 COL 40 PIC A(08) AUTO-SKIP USING W-DATA + HIGHLIGHT. + 02 LINE + 2 COL 40 PIC X AUTO-SKIP USING W-REPLY + HIGHLIGHT. + + PROCEDURE DIVISION. + + MAIN-LOOP. + DISPLAY SCREEN-SELECTION + CALL 'TIMEDISP' + + PERFORM WITH TEST AFTER UNTIL WCRT-STATUS <> K-TIMEOUT + ACCEPT SCREEN-SELECTION WITH TIMEOUT 1 + ON EXCEPTION CALL 'TIMEDISP' + END-ACCEPT + END-PERFORM. + + IF SUCCESS AND WCRT-STATUS = 0 + GOBACK RETURNING 0 + ELSE + GOBACK RETURNING 1 + END-IF + . + + GOBACK. + + ** ************************************************************* + * + ** ************************************************************* + ID DIVISION. + PROGRAM-ID. TIMEDISP. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 SWITCH PIC X. + 01 BLUE CONSTANT AS 01. + 01 RED CONSTANT AS 04. + 01 CYAN CONSTANT AS 03. + 01 WHITE CONSTANT AS 07. + 01 WDAY PIC 9(08). + 01 WTIME PIC 9(08). + 01 DATE-TIME PIC X(19). + PROCEDURE DIVISION. + ACCEPT WDAY FROM DATE YYYYMMDD + ACCEPT WTIME FROM TIME + STRING WDAY(1:4) '.' WDAY(5:2) '.' WDAY(7:2) ' ' + WTIME(1:2) ':' WTIME(3:2) ':' WTIME(5:2) DELIMITED BY + SIZE INTO DATE-TIME + IF SWITCH EQUAL 'N' + DISPLAY DATE-TIME AT 002061 :BCOL: CYAN :FCOL: WHITE + END-DISPLAY + MOVE 'Y' TO SWITCH + ELSE + DISPLAY DATE-TIME AT 002061 :BCOL: RED :FCOL: WHITE + END-DISPLAY + MOVE 'N' TO SWITCH + END-IF. + CONTINUE. + ENDPROGRAM. + GOBACK. + END PROGRAM TIMEDISP. + + END PROGRAM PROG. +]) + +AT_CHECK([$COMPILE prog.cob], [0], [], []) +MANUAL_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) + +AT_CLEANUP From 3edbc6d1f70b0a642c07d056d3ecc2c215731665 Mon Sep 17 00:00:00 2001 From: Simon Sobisch Date: Thu, 31 Oct 2024 12:43:32 +0100 Subject: [PATCH 14/29] Update .gitpod.yml adjust gitpod config for current version --- .gitpod.yml | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/.gitpod.yml b/.gitpod.yml index ee365640a..21a39fabe 100644 --- a/.gitpod.yml +++ b/.gitpod.yml @@ -3,17 +3,17 @@ image: gitpod/workspace-c tasks: -- name: setup coding environment on Ubuntu 20.04 +- name: setup coding environment on Ubuntu 22.04 before: | # note: sadly we need this to be done every time as only /workspace is kept, but linked # against those dependencies; and also we do want to recompile after adjustments # this can all be dropped as soon as we would use a prepared docker sudo apt update && sudo apt upgrade -y sudo apt install -y build-essential libgmp-dev libdb-dev libjson-c-dev ncurses-dev libxml2-dev \ - automake libtool flex bison help2man texinfo \ + automake libtool flex bison help2man gettext texinfo \ lcov \ clangd bear - # sudo apt install gettext texlive-base # for make dist (po/*, doc/gnucobol.pdf) + # sudo apt install texlive-base # for make dist (doc/gnucobol.pdf) gp sync-done system-prepare - name: building GnuCOBOL From a6c4f2440452661e69004da5178196e835f387b9 Mon Sep 17 00:00:00 2001 From: ddeclerck Date: Mon, 18 Nov 2024 14:57:51 +0000 Subject: [PATCH 15/29] Add XML/JSON GENERATE tests for PIC P --- libcob/mlio.c | 2 - tests/testsuite.src/run_ml.at | 72 ++++++++++++++++++++++++++++++++++- 2 files changed, 71 insertions(+), 3 deletions(-) diff --git a/libcob/mlio.c b/libcob/mlio.c index 67c52e443..ec11d0313 100644 --- a/libcob/mlio.c +++ b/libcob/mlio.c @@ -363,8 +363,6 @@ get_num (cob_field * const f, void * (*strndup_func)(const char *, size_t), char *dp_pos; void *num; - /* TODO: add test cases with PPP99 and 9PPP to verify it works "as expected" */ - /* Initialize attribute for nicely edited version of f */ attr.type = COB_TYPE_NUMERIC_EDITED; attr.flags = COB_FIELD_HAVE_SIGN (f) ? diff --git a/tests/testsuite.src/run_ml.at b/tests/testsuite.src/run_ml.at index 2b94f4bb2..a408ae59a 100644 --- a/tests/testsuite.src/run_ml.at +++ b/tests/testsuite.src/run_ml.at @@ -529,6 +529,41 @@ AT_CHECK([$COBCRUN_DIRECT ./prog], [0], AT_CLEANUP +AT_SETUP([XML GENERATE PICTURE P]) +AT_KEYWORDS([extensions]) + +AT_SKIP_IF([test "$COB_HAS_XML2" = "no"]) + +AT_DATA([prog.cob], [ + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 WS-999PPP PIC 999PPP VALUE 123000. + 01 WS-PPP999 PIC PPP999 VALUE 0.000123. + + 01 out PIC X(300). + + PROCEDURE DIVISION. + XML GENERATE out FROM WS-999PPP + IF out <> '123000' + DISPLAY "Failed 1: " FUNCTION TRIM (out) + END-IF + + XML GENERATE out FROM WS-PPP999 + IF out <> '0.000123' + DISPLAY "Failed 2: " FUNCTION TRIM (out) + END-IF + . +]) + +AT_CHECK([$COMPILE prog.cob], [0], [], []) +AT_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) +AT_CLEANUP + + + AT_SETUP([JSON GENERATE general]) AT_KEYWORDS([extensions]) @@ -647,7 +682,7 @@ AT_DATA([prog.cob], [ PROCEDURE DIVISION. JSON GENERATE short-str FROM valid-rec COUNT IN json-len - IF short-str <> '{"val' + IF short-str <> '{"val' *> " OR json-len <> 33 OR JSON-CODE <> 1 DISPLAY "Failed 1: " short-str " " json-len " " JSON-CODE @@ -907,3 +942,38 @@ AT_CHECK([$COBCRUN_DIRECT ./prog], [0], [{"num":1,1} ]) AT_CLEANUP + + +AT_SETUP([JSON GENERATE PICTURE P]) +AT_KEYWORDS([extensions]) + +AT_SKIP_IF([test "$COB_HAS_JSON" = "no"]) + + +AT_DATA([prog.cob], [ + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 WS-999PPP PIC 999PPP VALUE 123000. + 01 WS-PPP999 PIC PPP999 VALUE 0.000123. + + 01 out PIC X(300). + + PROCEDURE DIVISION. + JSON GENERATE out FROM WS-999PPP + IF out <> '{"WS-999PPP":123000}' + DISPLAY "Failed 1: " FUNCTION TRIM (out) + END-IF + + JSON GENERATE out FROM WS-PPP999 + IF out <> '{"WS-PPP999":0.000123}' + DISPLAY "Failed 2: " FUNCTION TRIM (out) + END-IF + . +]) + +AT_CHECK([$COMPILE prog.cob], [0], [], []) +AT_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) +AT_CLEANUP From 2a53351eae5a6c53f5408a2594d651fe3d47cdb2 Mon Sep 17 00:00:00 2001 From: chaat Date: Mon, 18 Nov 2024 22:14:48 +0000 Subject: [PATCH 16/29] Add PANEL functions from CURSES * configure.ac: added logic to check for PANEL support which is required for the new multiple window support * cobc/typeck.c: define [WITH_EXTENDED_SCREENIO] for any curses headers available, which now includes panel.h definitions * libcob: * screenio.c added new functions for multiple window support. also added new static variables to support panel functions and a static array to store information about the panels which have been created. cob_sys_window, check_panel_parm, cob_update_all_windows, refresh_mywin * common.h: added cob_sys_window * system.def: added system library call CBL_GC_WINDOW * doc/gnucobol.texi: document new multiple window function * copy/gcwindow.cpy, copy/Makefile.am: new copy for CBL_GC_WINDOW functions --- ChangeLog | 5 + NEWS | 4 +- build_windows/config.h.in | 96 +- cobc/ChangeLog | 5 + cobc/typeck.c | 5 + configure.ac | 25 +- copy/ChangeLog | 4 + copy/Makefile.am | 6 +- copy/gcwindow.cpy | 105 + doc/ChangeLog | 6 +- doc/gnucobol.texi | 29 + libcob/ChangeLog | 13 + libcob/common.h | 5 + libcob/screenio.c | 877 ++- libcob/system.def | 7 +- tests/testsuite.src/run_manual_screen.at | 8023 ++++++++++++---------- 16 files changed, 5325 insertions(+), 3890 deletions(-) create mode 100644 copy/gcwindow.cpy diff --git a/ChangeLog b/ChangeLog index d790fe60a..856a4be31 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,4 +1,9 @@ +2024-10-30 Simon Sobisch + + * configure.ac: added logic to check for PANEL support which + is required for the new multiple window support + 2024-10-02 Simon Sobisch * configure.ac: new options --with-pkgversion=PKG and --with-bugurl=URL diff --git a/NEWS b/NEWS index 306f35115..8f0d220fb 100644 --- a/NEWS +++ b/NEWS @@ -20,9 +20,11 @@ NEWS - user visible changes -*- outline -*- customization can be done using COB_PROF_FILE, COB_PROF_MAX_DEPTH and COB_PROF_FORMAT -** new runtime configuraiton COB_HIDE_CURSOR, allows to hide the cursor during +** new runtime configuration COB_HIDE_CURSOR, allows to hide the cursor during extended ScreenIO operations +** added multiple window functionality with new system function CBL_GC_WINDOW + more work in progress * Changes that potentially effect recompilation of existing programs: diff --git a/build_windows/config.h.in b/build_windows/config.h.in index 44343b870..dfe4f9176 100644 --- a/build_windows/config.h.in +++ b/build_windows/config.h.in @@ -367,7 +367,7 @@ /* Has __attribute__((pure)) */ /* #undef HAVE_ATTRIBUTE_PURE */ -/* Define to 1 if you have the `canonicalize_file_name' function. */ +/* Define to 1 if you have the 'canonicalize_file_name' function. */ #if defined(__ORANGEC__) #define HAVE_CANONICALIZE_FILE_NAME 1 #else @@ -428,11 +428,11 @@ */ /* #undef HAVE_DCGETTEXT */ -/* Define to 1 if you have the declaration of `fdatasync', and to 0 if you +/* Define to 1 if you have the declaration of 'fdatasync', and to 0 if you don't. */ #define HAVE_DECL_FDATASYNC 0 -/* Define to 1 if you have the declaration of `fmemopen', and to 0 if you +/* Define to 1 if you have the declaration of 'fmemopen', and to 0 if you don't. */ #if defined(__ORANGEC__) #define HAVE_DECL_FMEMOPEN 1 @@ -462,10 +462,10 @@ /* Define to 1 if you have the header file. */ /* #undef HAVE_DLFCN_H */ -/* Define to 1 if you don't have `vprintf' but do have `_doprnt.' */ +/* Define to 1 if you don't have 'vprintf' but do have '_doprnt.' */ /* #undef HAVE_DOPRNT */ -/* Define to 1 if you have the `fcntl' function. */ +/* Define to 1 if you have the 'fcntl' function. */ #if defined(__ORANGEC__) #define HAVE_FCNTL 1 #else @@ -475,27 +475,27 @@ /* Define to 1 if you have the header file. */ #define HAVE_FCNTL_H 1 -/* Define to 1 if you have the `fdatasync' function. */ +/* Define to 1 if you have the 'fdatasync' function. */ /* #undef HAVE_FDATASYNC */ /* Declaration of finite function in ieeefp.h instead of math.h */ /* #undef HAVE_FINITE_IEEEFP_H */ -/* Define to 1 if you have the `flockfile' function. */ +/* Define to 1 if you have the 'flockfile' function. */ #if defined(__ORANGEC__) #define HAVE_FLOCKFILE 1 #else /* #undef HAVE_FLOCKFILE */ #endif -/* Define to 1 if you have the `fmemopen' function. */ +/* Define to 1 if you have the 'fmemopen' function. */ #if defined(__ORANGEC__) #define HAVE_FMEMOPEN 1 #else /* #undef HAVE_FMEMOPEN */ #endif -/* Define to 1 if you have the `getexecname' function. */ +/* Define to 1 if you have the 'getexecname' function. */ #if defined(__ORANGEC__) #define HAVE_GETEXECNAME 1 #else @@ -505,7 +505,7 @@ /* Define if the GNU gettext() function is already present or preinstalled. */ /* #undef HAVE_GETTEXT */ -/* Define to 1 if you have the `gettimeofday' function. */ +/* Define to 1 if you have the 'gettimeofday' function. */ #if defined(__ORANGEC__) #define HAVE_GETTIMEOFDAY 1 #else @@ -564,13 +564,13 @@ /* Define if you have and nl_langinfo(CODESET). */ /* #undef HAVE_LANGINFO_CODESET */ -/* Define to 1 if you have the `posix4' library (-lposix4). */ +/* Define to 1 if you have the 'posix4' library (-lposix4). */ /* #undef HAVE_LIBPOSIX4 */ -/* Define to 1 if you have the `rt' library (-lrt). */ +/* Define to 1 if you have the 'rt' library (-lrt). */ /* #undef HAVE_LIBRT */ -/* Define to 1 if you have the `localeconv' function. */ +/* Define to 1 if you have the 'localeconv' function. */ #define HAVE_LOCALECONV 1 /* Define to 1 if you have the header file. */ @@ -579,13 +579,13 @@ /* Define to 1 if you have the header file. */ /* #undef HAVE_LTDL_H */ -/* Define to 1 if you have the `memmove' function. */ +/* Define to 1 if you have the 'memmove' function. */ #define HAVE_MEMMOVE 1 /* Define to 1 if you have the header file. */ #define HAVE_MEMORY_H 1 -/* Define to 1 if you have the `memset' function. */ +/* Define to 1 if you have the 'memset' function. */ #define HAVE_MEMSET 1 /* curses has mouseinterval function */ @@ -621,6 +621,9 @@ /* Define to 1 if you have the header file. */ /* #undef HAVE_NCURSESW_NCURSES_H */ +/* Define to 1 if you have the header file. */ +/* #undef HAVE_NCURSESW_PANEL_H */ + /* Define to 1 if you have the header file. */ /* #undef HAVE_NCURSES_CURSES_H */ @@ -630,19 +633,25 @@ /* Define to 1 if you have the header file. */ /* #undef HAVE_NCURSES_NCURSES_H */ +/* Define to 1 if you have the header file. */ +/* #undef HAVE_NCURSES_PANEL_H */ + +/* Define to 1 if you have the header file. */ +/* #undef HAVE_PANEL_H */ + /* Define to 1 if you have the header file. */ /* #undef HAVE_PDCURSES_H */ -/* Define to 1 if you have the `popen' function. */ +/* Define to 1 if you have the 'popen' function. */ #define HAVE_POPEN 1 -/* Define to 1 if you have the `raise' function. */ +/* Define to 1 if you have the 'raise' function. */ #define HAVE_RAISE 1 -/* Define to 1 if you have the `readlink' function. */ +/* Define to 1 if you have the 'readlink' function. */ /* #undef HAVE_READLINK */ -/* Define to 1 if you have the `realpath' function. */ +/* Define to 1 if you have the 'realpath' function. */ #if defined(__ORANGEC__) #define HAVE_REALPATH 1 #else @@ -652,19 +661,19 @@ /* curses has resize_term function */ #define HAVE_RESIZE_TERM 1 -/* Define to 1 if you have the `setenv' function. */ -/* MSC does *NOT* have `setenv' (!) - But as the handling of the fallback `putenv' is different in POSIX and _MSC - (POSIX stores no duplicate of `putenv', where _MSC does), we pretend to - have support for `setenv' and define it in common.c using _putenv_s, +/* Define to 1 if you have the 'setenv' function. */ +/* MSC does *NOT* have 'setenv' (!) + But as the handling of the fallback 'putenv' is different in POSIX and _MSC + (POSIX stores no duplicate of 'putenv', where _MSC does), we pretend to + have support for 'setenv' and define it in common.c using _putenv_s, omitting the override parameter ORANGEC provides the function */ #define HAVE_SETENV 1 -/* Define to 1 if you have the `setlocale' function. */ +/* Define to 1 if you have the 'setlocale' function. */ #define HAVE_SETLOCALE 1 -/* Define to 1 if you have the `sigaction' function. */ +/* Define to 1 if you have the 'sigaction' function. */ #if defined(__ORANGEC__) #define HAVE_SIGACTION 1 #else @@ -674,7 +683,7 @@ /* Define to 1 if you have the header file. */ #define HAVE_SIGNAL_H 1 -/* Define to 1 if the system has the type `sig_atomic_t'. */ +/* Define to 1 if the system has the type 'sig_atomic_t'. */ #define HAVE_SIG_ATOMIC_T 1 /* Define to 1 if you have the header file. */ @@ -691,19 +700,19 @@ /* Define to 1 if you have the header file. */ #define HAVE_STDLIB_H 1 -/* Define to 1 if you have the `strcasecmp' function. */ +/* Define to 1 if you have the 'strcasecmp' function. */ #define HAVE_STRCASECMP 1 -/* Define to 1 if you have the `strchr' function. */ +/* Define to 1 if you have the 'strchr' function. */ #define HAVE_STRCHR 1 -/* Define to 1 if you have the `strcoll' function. */ +/* Define to 1 if you have the 'strcoll' function. */ #define HAVE_STRCOLL 1 -/* Define to 1 if you have the `strdup' function. */ +/* Define to 1 if you have the 'strdup' function. */ #define HAVE_STRDUP 1 -/* Define to 1 if you have the `strerror' function. */ +/* Define to 1 if you have the 'strerror' function. */ #define HAVE_STRERROR 1 /* Define to 1 if you have the header file. */ @@ -716,13 +725,13 @@ /* Define to 1 if you have the header file. */ #define HAVE_STRING_H 1 -/* Define to 1 if you have the `strrchr' function. */ +/* Define to 1 if you have the 'strrchr' function. */ #define HAVE_STRRCHR 1 -/* Define to 1 if you have the `strstr' function. */ +/* Define to 1 if you have the 'strstr' function. */ #define HAVE_STRSTR 1 -/* Define to 1 if you have the `strtol' function. */ +/* Define to 1 if you have the 'strtol' function. */ #define HAVE_STRTOL 1 /* Define to 1 if you have the header file. */ @@ -759,7 +768,7 @@ /* #undef HAVE_VBISAM_H */ #endif -/* Define to 1 if you have the `vprintf' function. */ +/* Define to 1 if you have the 'vprintf' function. */ #define HAVE_VPRINTF 1 /* Define to 1 if you have the header file. */ @@ -768,6 +777,9 @@ /* Define to 1 if you have the header file. */ /* #undef HAVE_XCURSES_H */ +/* Define to 1 if you have the header file. */ +/* #undef HAVE_XCURSES_PANEL_H */ + /* Define as const if the declaration of iconv() needs const. */ /* #undef ICONV_CONST */ @@ -866,7 +878,7 @@ /* Define to 1 if you have the ANSI C header files. */ #define STDC_HEADERS 1 -/* Define to 1 if your declares `struct tm'. */ +/* Define to 1 if your declares 'struct tm'. */ /* #undef TM_IN_SYS_TIME */ /* Use system dynamic loader */ @@ -990,8 +1002,8 @@ # endif #endif -/* Define to 1 if `lex' declares `yytext' as a `char *' by default, not a - `char[]'. */ +/* Define to 1 if 'lex' declares 'yytext' as a 'char *' by default, not a + 'char[]'. */ #define YYTEXT_POINTER 1 /* Define to 1 if on MINIX. */ @@ -1001,7 +1013,7 @@ this defined. */ /* #undef _POSIX_1_SOURCE */ -/* Define to 1 if you need to in order for `stat' and other things to work. */ +/* Define to 1 if you need to in order for 'stat' and other things to work. */ /* #undef _POSIX_SOURCE */ /* Define to 1 if on HPUX. */ @@ -1009,10 +1021,10 @@ /* # undef _XOPEN_SOURCE_EXTENDED */ #endif -/* Define to empty if `const' does not conform to ANSI C. */ +/* Define to empty if 'const' does not conform to ANSI C. */ /* #undef const */ -/* Define to `unsigned int' if does not define. */ +/* Define to 'unsigned int' if does not define. */ /* #undef size_t */ #ifdef ENABLE_NLS diff --git a/cobc/ChangeLog b/cobc/ChangeLog index 8c5853b8e..962ce3023 100644 --- a/cobc/ChangeLog +++ b/cobc/ChangeLog @@ -1,4 +1,9 @@ +2024-10-30 Chuck Haatvedt + + * typeck.c: define [WITH_EXTENDED_SCREENIO] for any curses headers + available, which now includes panel.h definitions + 2024-10-02 Simon Sobisch * pplex.l (output_line_directive): extracted from other places and diff --git a/cobc/typeck.c b/cobc/typeck.c index 3f87068dd..280fa922d 100644 --- a/cobc/typeck.c +++ b/cobc/typeck.c @@ -46,6 +46,11 @@ defined (HAVE_PDCURSES_CURSES_H) || \ defined (HAVE_XCURSES_H) || \ defined (HAVE_XCURSES_CURSES_H) || \ + defined (HAVE_NCURSESW_PANEL_H) || \ + defined (HAVE_NCURSES_PANEL_H) || \ + defined (HAVE_PDCURSES_PANEL_H) || \ + defined (HAVE_XCURSES_PANEL_H) || \ + defined (HAVE_PANEL_H) || \ defined (HAVE_CURSES_H) #define WITH_EXTENDED_SCREENIO #endif diff --git a/configure.ac b/configure.ac index 703d359b2..c0b012267 100644 --- a/configure.ac +++ b/configure.ac @@ -1424,12 +1424,17 @@ if test "x$CURSES_LIBS" = x; then ac_cv_lib_ncursesw_initscr=yes ]) ]) + if test "x$PANEL_LIBS" = x; then + PKG_CHECK_MODULES([PANEL], [panelw], [ac_cv_lib_panelw_new_panel=yes], [ + AC_CHECK_LIB([panelw], [new_panel], [PANEL_LIBS=-lpanelw]) + ]) + fi fi fi if test "$USE_CURSES" = "ncursesw" -o "x$ac_cv_lib_ncursesw_initscr" = xyes; then CPPFLAGS="$NCURSES_CFLAGS $CPPFLAGS" dnl note: at least OpenBSD has ncursesw only with only ncurses.h in default header directory - AC_CHECK_HEADERS([ncursesw/ncurses.h ncursesw/curses.h ncurses.h], + AC_CHECK_HEADERS([ncursesw/panel.h ncursesw/ncurses.h ncursesw/curses.h panel.h ncurses.h], [USE_CURSES="ncursesw" break], [AS_IF([test "$USE_CURSES" != check], @@ -1461,12 +1466,17 @@ if test "x$CURSES_LIBS" = x; then ac_cv_lib_ncurses_initscr=yes ]) ]) + if test "x$PANEL_LIBS" = x; then + PKG_CHECK_MODULES([PANEL], [panel], [ac_cv_lib_panel_new_panel=yes], [ + AC_CHECK_LIB([panel], [new_panel], [PANEL_LIBS=-lpanel]) + ]) + fi fi fi if test "$USE_CURSES" = "ncurses" -o "x$ac_cv_lib_ncurses_initscr" = xyes; then CPPFLAGS="$NCURSES_CFLAGS $CPPFLAGS" - AC_CHECK_HEADERS([ncurses/ncurses.h ncurses/curses.h ncurses.h], + AC_CHECK_HEADERS([ncurses/panel.h ncurses/ncurses.h ncurses/curses.h panel.h ncurses.h], [USE_CURSES="ncurses" break], [AS_IF([test "$USE_CURSES" != check], @@ -1484,7 +1494,7 @@ if test "x$CURSES_LIBS" = x; then fi fi if test "$USE_CURSES" = "pdcurses" -o "x$ac_cv_lib_pdcurses_initscr" = xyes; then - AC_CHECK_HEADERS([pdcurses.h curses.h], + AC_CHECK_HEADERS([panel.h pdcurses.h curses.h], [USE_CURSES="pdcurses" break], [AS_IF([test "$USE_CURSES" != check], @@ -1502,7 +1512,7 @@ if test "x$CURSES_LIBS" = x; then fi fi if test "$USE_CURSES" = "xcurses" -o "x$ac_cv_lib_XCurses_initscr" = xyes; then - AC_CHECK_HEADERS([xcurses/curses.h xcurses.h], + AC_CHECK_HEADERS([xcurses/panel.h xcurses/curses.h xcurses.h], [USE_CURSES="xcurses" break], [AS_IF([test "$USE_CURSES" != check], @@ -1517,6 +1527,9 @@ if test "x$CURSES_LIBS" = x; then AC_CHECK_LIB([curses], [initscr], [true], [AS_IF([test "$USE_CURSES" != check], [USE_CURSES="missing_lib"])]) fi + if test "x$PANEL_LIBS" = x; then + AC_CHECK_LIB([panel], [new_panel], [PANEL_LIBS=-lpanel]) + fi fi if test "$USE_CURSES" = "curses" -o "x$ac_cv_lib_curses_initscr" = xyes; then AC_CHECK_HEADERS([curses.h], [USE_CURSES="curses"], @@ -1541,8 +1554,8 @@ case "$USE_CURSES" in ;; *curses*) AC_DEFINE_UNQUOTED([WITH_CURSES], ["$USE_CURSES"]) - LIBCOB_LIBS="$LIBCOB_LIBS $CURSES_LIBS" - LIBCOB_CPPFLAGS="$CURSES_CFLAGS $LIBCOB_CPPFLAGS" + LIBCOB_LIBS="$LIBCOB_LIBS $CURSES_LIBS $PANEL_LIBS" + LIBCOB_CPPFLAGS="$CURSES_CFLAGS $PANEL_CFLAGS $LIBCOB_CPPFLAGS" ;; esac diff --git a/copy/ChangeLog b/copy/ChangeLog index b2a9b1c1f..66484c9ee 100644 --- a/copy/ChangeLog +++ b/copy/ChangeLog @@ -1,4 +1,8 @@ +2024-09-30 Chuck Haatvedt + + * gcwindow.cpy, Makefile.am: new copy for CBL_GC_WINDOW functions + 2021-09-05 Simon Sobisch * xfhfcd3.cpy: Change PIC X(n) to PIC X COMP-X OCCURS n diff --git a/copy/Makefile.am b/copy/Makefile.am index e1150c4c3..7283dc3c2 100644 --- a/copy/Makefile.am +++ b/copy/Makefile.am @@ -1,8 +1,8 @@ # # Makefile gnucobol/copy # -# Copyright (C) 2008-2012, 2018 Free Software Foundation, Inc. -# Written by Roger While +# Copyright (C) 2008-2012, 2018, 2019, 2024 Free Software Foundation, Inc. +# Written by Roger While, Simon Sobisch # # This file is part of GnuCOBOL. # @@ -20,6 +20,6 @@ # along with GnuCOBOL. If not, see . copydir = @COB_COPY_DIR@ -copy_DATA = screenio.cpy sqlca.cpy sqlda.cpy xfhfcd.cpy xfhfcd3.cpy +copy_DATA = gcwindow.cpy screenio.cpy sqlca.cpy sqlda.cpy xfhfcd.cpy xfhfcd3.cpy EXTRA_DIST = $(copy_DATA) diff --git a/copy/gcwindow.cpy b/copy/gcwindow.cpy new file mode 100644 index 000000000..6b795be5f --- /dev/null +++ b/copy/gcwindow.cpy @@ -0,0 +1,105 @@ + *> Copyright (C) 2024 + *> Free Software Foundation, Inc. + *> Written by Chuck Haatvedt, Simon Sobisch + *> + *> This file is part of GnuCOBOL. + *> + *> The GnuCOBOL compiler is free software: you can redistribute + *> it and/or modify it under the terms of the GNU General Public + *> License as published by the Free Software Foundation, either + *> version 3 of the License, or (at your option) any later + *> version. + *> + *> GnuCOBOL is distributed in the hope that it will be useful, + *> but WITHOUT ANY WARRANTY; without even the implied warranty of + *> MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + *> GNU General Public License for more details. + *> + *> You should have received a copy of the GNU General Public + *> License along with GnuCOBOL. + *> If not, see . + + *>* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * + *> * + *> THIS COMMUNICATION AREA IS USED TO RETRIEVE * + *> INFORMATION ABOUT THE WINDOWS WHICH HAVE BEEN CREATED * + *> BY THE CBL_GC_WINDOW_NEW FUNCTION. IT WILL REPORT ON * + *> ALL OF THE WINDOWS BOTH ACTIVE AND HIDDEN. THE ACTIVE * + *> WINDOWS WILL BE IN ORDER OF THEIR DEPTH ON THE STACK * + *> OF WINDOWS. AN ENTRY OF ALL LOW VALUES WILL REPRESENT * + *> THE NON EXISTANCE OF ANY MORE WINDOWS. * + *> * + *>* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * + + 01 WL-WINDOW-LIST. + 05 WL-WINDOW OCCURS 20 TIMES + INDEXED BY WL-INDEX. + 10 WL-DEPTH PIC S9(4) COMP-5. + 10 WL-WINDOW-NUMBER PIC S9(4) COMP-5. + 10 WL-WINDOW-POSITION-ROW PIC S9(4) COMP-5. + 10 WL-WINDOW-POSITION-COL PIC S9(4) COMP-5. + 10 WL-WINDOW-SIZE-ROW PIC S9(4) COMP-5. + 10 WL-WINDOW-SIZE-COL PIC S9(4) COMP-5. + 10 WL-WINDOW-FG-COLOR PIC S9(4) COMP-5. + 10 WL-WINDOW-BG-COLOR PIC S9(4) COMP-5. + 10 WL-WINDOW-HIDDEN PIC S9(4) COMP-5. + + *>* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * + *> * + *> This copy member is used to call the Multiple Window * + *> CBL_GC_WINDOW functions. Note that in addition to * + *> checking the WP-WINDOW-RETURN-CODE field you should * + *> also check the COBOL RETURN-CODE as these functions * + *> only work when in extended i/o mode. See the * + *> Programmers Guide for more information on the use of * + *> these functions. * + *> * + *>* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * + + 01 WP-WINDOW-PARMS. + 05 WP-WINDOW-MODE PIC 9(09) COMP-5. + 88 WP-MODE-NEW-WINDOW VALUE 1. + 88 WP-MODE-DELETE-WINDOW VALUE 2. + 88 WP-MODE-MOVE-WINDOW VALUE 3. + 88 WP-MODE-SHOW-WINDOW VALUE 4. + 88 WP-MODE-HIDE-WINDOW VALUE 5. + 88 WP-MODE-TOP-WINDOW VALUE 6. + 88 WP-MODE-BOTTOM-WINDOW VALUE 7. + *> 88 WP-MODE-LIST-WINDOW VALUE 8. + 05 WP-WINDOW-NUMBER PIC 9(09) COMP-5. + 05 WP-WINDOW-START-ROW PIC 9(09) COMP-5. + 05 WP-WINDOW-START-COL PIC 9(09) COMP-5. + 05 WP-WINDOW-ROWS PIC 9(09) COMP-5. + 05 WP-WINDOW-COLUMNS PIC 9(09) COMP-5. + 05 WP-WINDOW-FG-COLOR PIC 9(09) COMP-5. + 05 WP-WINDOW-BG-COLOR PIC 9(09) COMP-5. + 05 WP-WINDOW-HIDDEN PIC 9(09) COMP-5. + 05 WP-WINDOW-RETURN-CODE PIC 9(09) COMP-5. + 88 WP-OK VALUE 0. + 88 WP-START-Y-EXCEEDS-MAX VALUE 2. + 88 WP-START-X-EXCEEDS-MAX VALUE 4. + 88 WP-WIN-ROWS-EXCEEDS-MAX VALUE 6. + 88 WP-WIN-COLS-EXCEEDS-MAX VALUE 7. + 88 WP-INVALID-BG-COLOR VALUE 8. + 88 WP-INVALID-FG-COLOR VALUE 9. + 88 WP-WIN-NUMBER-INVALID VALUE 10. + 88 WP-FG-BG-COLORS-ARE-SAME VALUE 11. + 88 WP-WIN-HIDDEN-NOT-1 VALUE 12. + 88 WP-WIN-HIDDEN-NOT-0 VALUE 14. + 88 WP-TOP-WIN-NBR-INVALID VALUE 16. + 88 WP-BOTTOM-WIN-NBR-INVALID VALUE 18. + 88 WP-NO-MORE-WINDOWS-LEFT VALUE 20. + 88 WP-NEWWIN-FAILED VALUE 22. + 88 WP-NEW-PANEL-FAILED VALUE 24. + 88 WP-PAN-USRPTR-FAILED VALUE 26. + 88 WP-WINDOW-NOT-FOUND VALUE 28. + 88 WP-MOVE-WINDOW-FAILED VALUE 29. + 88 WP-SHOW-WINDOW-FAILED VALUE 30. + 88 WP-HIDE-WINDOW-FAILED VALUE 32. + 88 WP-TOP-WINDOW-FAILED VALUE 34. + 88 WP-BOTTOM-WINDOW-FAILED VALUE 35. + 88 WP-DELETE-WINDOW-FAILED VALUE 36. + 88 WP-DELETE-PANEL-FAILED VALUE 38. + 88 WP-WINDOW-IS-HIDDEN VALUE 40. + 88 WP-WINDOW-IS-NOT-HIDDEN VALUE 42. + 88 WP-WINDOW-MODE-IS-INVALID VALUE 44. diff --git a/doc/ChangeLog b/doc/ChangeLog index 1f25414cd..0426aa852 100644 --- a/doc/ChangeLog +++ b/doc/ChangeLog @@ -1,4 +1,8 @@ +2024-10-30 Chuck Haatvedt + + * gnucobol.texi: document new multiple window function + 2024-03-15 Fabrice Le Fessant * gnucobol.texi: document new dependencies options @@ -283,7 +287,7 @@ * gnucobol.texi: new section "Extensions" to document FR #37 WITH SIZE for ACCEPT/DISPLAY field -2014-14-04 Philipp Böhme +2014-14-04 Philipp B�hme * gnucobol.texi: Added documentation for CBL_OC_GETOPT diff --git a/doc/gnucobol.texi b/doc/gnucobol.texi index 29fa893f4..2d0f38afa 100644 --- a/doc/gnucobol.texi +++ b/doc/gnucobol.texi @@ -179,6 +179,7 @@ System Routines * CBL_GC_NANOSLEEP Sleep for nanoseconds * CBL_GC_FORK Fork the current COBOL process to a new one * CBL_GC_WAITPID Wait for a system process to end +* CBL_GC_WINDOW Multiple Window functions Appendices @@ -2463,6 +2464,8 @@ For a complete list of supported system routines, * CBL_GC_NANOSLEEP:: Sleep for nanoseconds * CBL_GC_FORK:: Fork the current COBOL process to a new one * CBL_GC_WAITPID:: Wait for a system process to end +* CBL_GC_WINDOW:: Multiple Window functions + @end menu @node CBL_GC_GETOPT @@ -2827,6 +2830,32 @@ is not available on the current system. END-DISPLAY @end example + +@node CBL_GC_WINDOW +@section CBL_GC_WINDOW + +@code{CBL_GC_WINDOW} allows you to create, move, hide, show, top, bottom +or list multiple windows if your installation supports CURSES & PANELS. +Note windows have depth like a stack of cards on a flat table. Each window +has its contents independent of any other window. All of the writes to +the console are directed to the window on top of the deck of windows. +Note that you need to check the COBOL RETURN-CODE and the WP-RETURN-CODE +after calling CBL_GC_WINDOW. + +Parameters: the WP-PARM.CPY copy member is used for all calls except +the LIST function which uses the WP-LIST.CPY copy member. See the +programmers guide for more information about the required parameters +which need to be used for the different function modes +Returns: COBOL RETURN-CODE and WP-RETURN-CODE (except for LIST function). +The non-zero RETURN-CODE is used to indicate either that PANEL functions +are not available in your installation of GNUCOBOL or the parm that you +used is not the correct length. + +@example + see the programmers guide for a sample program as it is a + bit too large to include here. +@end example + @node Appendices @menu diff --git a/libcob/ChangeLog b/libcob/ChangeLog index 92f1b255b..8396c3bef 100644 --- a/libcob/ChangeLog +++ b/libcob/ChangeLog @@ -1,4 +1,17 @@ +2024-11-18 Chuck Haatvedt + + * screenio.c added new functions for multiple window support. + also added new static variables to support panel functions + and a static array to store information about the panels + which have been created. + cob_sys_window + check_panel_parm + cob_update_all_windows + refresh_mywin + * common.h: added cob_sys_window + * system.def: added system library call CBL_GC_WINDOW + 2024-10-22 Chuck Haatvedt * screenio.c (cob_screen_get_all): fixed Bug #999 diff --git a/libcob/common.h b/libcob/common.h index c268eed79..ac3fda838 100644 --- a/libcob/common.h +++ b/libcob/common.h @@ -1052,6 +1052,8 @@ typedef cob_s64_t cob_flags_t; #define COB_SCREEN_NO_UPDATE ((cob_flags_t)1 << 34) /* used for syntax checking */ #define COB_SCREEN_SCROLL_UP ((cob_flags_t)1 << 35) /* used for syntax checking */ #define COB_SCREEN_GRID ((cob_flags_t)1 << 36) /* used for syntax checking */ +#define COB_SCREEN_POPUP_CREATE ((cob_flags_t)1 << 61) +#define COB_SCREEN_POPUP_REMOVE ((cob_flags_t)1 << 62) #define COB_SCREEN_TYPE_GROUP 0 #define COB_SCREEN_TYPE_FIELD 1 @@ -2180,6 +2182,9 @@ COB_EXPIMP int cob_sys_get_scr_size (unsigned char *, unsigned char *); COB_EXPIMP int cob_sys_set_scr_size (unsigned char *, unsigned char *); COB_EXPIMP int cob_sys_scr_dump (unsigned char *); COB_EXPIMP int cob_sys_scr_restore (unsigned char *); +#ifdef COB_EXPERIMENTAL +COB_EXPIMP int cob_sys_window (void *); +#endif COB_EXPIMP int cob_sys_get_char (unsigned char *); COB_EXPIMP int cob_get_text (char *, int); COB_EXPIMP int cob_get_scr_cols (void); diff --git a/libcob/screenio.c b/libcob/screenio.c index 5d70cd474..a8a6d3690 100644 --- a/libcob/screenio.c +++ b/libcob/screenio.c @@ -42,7 +42,33 @@ #include #endif -#if defined (HAVE_NCURSESW_NCURSES_H) +#if defined (HAVE_NCURSESW_PANEL_H) +#include +#define WITH_EXTENDED_SCREENIO +#define WITH_PANELS +#elif defined (HAVE_NCURSES_PANEL_H) +#include +#define WITH_EXTENDED_SCREENIO +#define WITH_PANELS +#elif defined (HAVE_PDCURSES_PANEL_H) +#define PDC_NCMOUSE /* use ncurses compatible mouse API */ +#include +#define WITH_EXTENDED_SCREENIO +#define WITH_PANELS +#elif defined (HAVE_XCURSES_PANEL_H) +#define PDC_NCMOUSE /* use ncurses compatible mouse API */ +#include +#define WITH_EXTENDED_SCREENIO +#define WITH_PANELS +#elif defined (HAVE_PANEL_H) +#define PDC_NCMOUSE /* see comment above */ +#include +#ifndef PDC_MOUSE_MOVED +#undef PDC_NCMOUSE +#endif +#define WITH_EXTENDED_SCREENIO +#define WITH_PANELS +#elif defined (HAVE_NCURSESW_NCURSES_H) #include #define WITH_EXTENDED_SCREENIO #elif defined (HAVE_NCURSESW_CURSES_H) @@ -146,13 +172,15 @@ static cob_settings *cobsetptr; static const cob_field_attr const_alpha_attr = {COB_TYPE_ALPHANUMERIC, 0, 0, 0, NULL}; static struct cob_inp_struct *cob_base_inp; -static size_t totl_index; -static size_t cob_has_color; +static size_t totl_index; +static size_t cob_has_color; static int global_return; static int cob_current_y; static int cob_current_x; -static short fore_color /* "const" default foreground (pair 0 on init) */; -static short back_color /* "const" default background (pair 0 on init) */; +static short fore_color /* "const" default foreground (pair 0 on init) */; +static short back_color /* "const" default background (pair 0 on init) */; +static short stdscr_fore_color /* "const" default foreground (pair 0 on init) */; +static short stdscr_back_color /* "const" default background (pair 0 on init) */; static int origin_y; static int origin_x; static int display_cursor_y; @@ -161,7 +189,89 @@ static int accept_cursor_y; static int accept_cursor_x; static int pending_accept; static int got_sys_char; +static int save_cursor_x = 0; +static int save_cursor_y = 0; static WINDOW *mywin; + +#ifdef WITH_PANELS +#define MAX_PANELS 20 +#define CBL_NEW_WINDOW 1 +#define CBL_DELETE_WINDOW 2 +#define CBL_MOVE_WINDOW 3 +#define CBL_SHOW_WINDOW 4 +#define CBL_HIDE_WINDOW 5 +#define CBL_TOP_WINDOW 6 +#define CBL_BOTTOM_WINDOW 7 +#define CBL_LIST_WINDOW 8 + +typedef struct __PARM_FLD + { + int mode; + int pan_number; + int starty; + int startx; + int win_rows; + int win_cols; + int fg_color; + int bg_color; + int hidden; + int ret_code; + } PARM_FLD, *PPARM_FLD; + +typedef struct __LIST_FLD + { + short pan_position; + short pan_number; + short starty; + short startx; + short win_rows; + short win_cols; + short input_fg_color; + short input_bg_color; + short hidden; + } LIST_FLD, *PLIST_FLD; + +typedef struct __PANEL_ENTRY + { + PANEL *pan; + WINDOW *win; + int starty; + int startx; + int win_rows; + int win_cols; + int hidden; + short fg_color; + short bg_color; + int input_fg_color; + int input_bg_color; + int pan_number; + } PANEL_ENTRY, *PPANEL_ENTRY; + + static PANEL_ENTRY my_panels[MAX_PANELS] = + { { NULL, NULL, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1} , + { NULL, NULL, 0, 0, 0, 0, 0, 0, 0, 0, 0, 2} , + { NULL, NULL, 0, 0, 0, 0, 0, 0, 0, 0, 0, 3} , + { NULL, NULL, 0, 0, 0, 0, 0, 0, 0, 0, 0, 4} , + { NULL, NULL, 0, 0, 0, 0, 0, 0, 0, 0, 0, 5} , + { NULL, NULL, 0, 0, 0, 0, 0, 0, 0, 0, 0, 6} , + { NULL, NULL, 0, 0, 0, 0, 0, 0, 0, 0, 0, 7} , + { NULL, NULL, 0, 0, 0, 0, 0, 0, 0, 0, 0, 8} , + { NULL, NULL, 0, 0, 0, 0, 0, 0, 0, 0, 0, 9} , + { NULL, NULL, 0, 0, 0, 0, 0, 0, 0, 0, 0, 10} , + { NULL, NULL, 0, 0, 0, 0, 0, 0, 0, 0, 0, 11} , + { NULL, NULL, 0, 0, 0, 0, 0, 0, 0, 0, 0, 12} , + { NULL, NULL, 0, 0, 0, 0, 0, 0, 0, 0, 0, 13} , + { NULL, NULL, 0, 0, 0, 0, 0, 0, 0, 0, 0, 14} , + { NULL, NULL, 0, 0, 0, 0, 0, 0, 0, 0, 0, 15} , + { NULL, NULL, 0, 0, 0, 0, 0, 0, 0, 0, 0, 16} , + { NULL, NULL, 0, 0, 0, 0, 0, 0, 0, 0, 0, 17} , + { NULL, NULL, 0, 0, 0, 0, 0, 0, 0, 0, 0, 18} , + { NULL, NULL, 0, 0, 0, 0, 0, 0, 0, 0, 0, 19} , + { NULL, NULL, 0, 0, 0, 0, 0, 0, 0, 0, 0, 20 } }; + + +#endif + #ifdef HAVE_MOUSEMASK static unsigned int curr_setting_mouse_flags = UINT_MAX; #endif @@ -171,6 +281,19 @@ static unsigned int curr_setting_mouse_flags = UINT_MAX; static int cob_screen_init (void); +#ifdef WITH_PANELS +void cob_update_all_windows (void); +int check_panel_parm (PPARM_FLD parm); +int cob_new_window (PPARM_FLD parm); +int cob_move_window (PPARM_FLD parm); +int cob_show_window (PPARM_FLD parm); +int cob_hide_window (PPARM_FLD parm); +int cob_delete_window (PPARM_FLD parm); +int cob_top_window (PPARM_FLD parm); +int cob_bottom_window (PPARM_FLD parm); +int cob_list_window (PLIST_FLD list); +#endif + /* Local functions */ /* @@ -301,6 +424,21 @@ handle_status (const int fret, const enum screen_statement stmt) #ifdef WITH_EXTENDED_SCREENIO +static COB_INLINE COB_A_INLINE void +refresh_mywin (WINDOW *curr_win) +{ + int pos_y, pos_x; + + if (curr_win != stdscr) { + getyx (curr_win, pos_y, pos_x); + if (wmouse_trafo (curr_win, &pos_y, &pos_x, 1)) { + move (pos_y, pos_x); + } + } + + wrefresh (curr_win); +} + static void cob_beep (void) { @@ -372,7 +510,7 @@ static short cob_get_color_pair (const short fg_color, const short bg_color) { /* default color (defined from terminal, read during init ) */ - if (fg_color == fore_color && bg_color == back_color) { + if (fg_color == stdscr_fore_color && bg_color == stdscr_back_color) { return 0; } /* reserved color "all black", defined during init */ @@ -1084,6 +1222,8 @@ cob_screen_init (void) if (has_colors ()) { start_color (); pair_content ((short)0, &fore_color, &back_color); + stdscr_fore_color = fore_color; + stdscr_back_color = back_color; /* fix bad settings of the terminal on start */ if (fore_color == back_color) { if (fore_color == COLOR_BLACK) { @@ -1847,7 +1987,7 @@ cob_screen_puts (cob_screen *s, cob_field *f, const cob_u32_t is_input, accept_cursor_x = column + f->size; } - wrefresh (mywin); + refresh_mywin (mywin); } static COB_INLINE COB_A_INLINE int @@ -2450,7 +2590,7 @@ cob_screen_get_all (const int initial_curs, const int accept_timeout) default_prompt_char = COB_CH_UL; } - wrefresh (mywin); + refresh_mywin (mywin); errno = 0; wtimeout (mywin, accept_timeout); keyp = getch (); @@ -2736,6 +2876,12 @@ cob_screen_get_all (const int initial_curs, const int accept_timeout) { int mline = mevent.y; int mcolumn = mevent.x; + /* translate mouse position from stdscr to current window; + error if outside current window */ + if (!wmouse_trafo (mywin, &mline, &mcolumn, 0)) { + cob_beep (); + continue; + } /* handle depending on state */ if (mevent.bstate & BUTTON1_PRESSED && COB_MOUSE_FLAGS & 1) { @@ -2911,7 +3057,7 @@ cob_screen_get_all (const int initial_curs, const int accept_timeout) cob_beep (); } screen_return: - wrefresh (mywin); + refresh_mywin (mywin); } static int @@ -2986,7 +3132,7 @@ cob_screen_moveyx (cob_screen *s) } cob_move_cursor (line, column); - wrefresh (mywin); + refresh_mywin (mywin); cob_current_y = line; cob_current_x = column; } @@ -3190,7 +3336,7 @@ screen_display (cob_screen *s, const int line, const int column) pending_accept = 1; } cob_screen_iterate (s); - wrefresh (mywin); + refresh_mywin (mywin); } static int @@ -3339,7 +3485,7 @@ field_display (cob_field *f, cob_flags_t fattr, const int line, const int column scrollok (mywin, 1); wscrl (mywin, sline); scrollok (mywin, 0); - wrefresh (mywin); + refresh_mywin (mywin); } sline = line; @@ -3387,7 +3533,7 @@ field_display (cob_field *f, cob_flags_t fattr, const int line, const int column } cob_move_cursor (sline, 0); } - wrefresh (mywin); + refresh_mywin (mywin); } static void @@ -3451,7 +3597,7 @@ field_accept (cob_field *f, cob_flags_t fattr, const int sline, const int scolum scrollok (mywin, 1); wscrl (mywin, keyp); scrollok (mywin, 0); - wrefresh (mywin); + refresh_mywin (mywin); } cobglobptr->cob_exception_code = 0; @@ -3619,7 +3765,7 @@ field_accept (cob_field *f, cob_flags_t fattr, const int sline, const int scolum /* Cursor to current column. */ cob_move_cursor (cline, ccolumn); /* Refresh screen. */ - wrefresh (mywin); + refresh_mywin (mywin); } errno = 0; @@ -4117,7 +4263,7 @@ field_accept (cob_field *f, cob_flags_t fattr, const int sline, const int scolum memset (COB_TERM_BUFF, ' ', size_accept); #endif } - wrefresh (mywin); + refresh_mywin (mywin); } static void @@ -4381,7 +4527,7 @@ cob_sys_clear_screen (void) init_cob_screen_if_needed (); wclear (mywin); - wrefresh (mywin); + refresh_mywin (mywin); cob_current_y = 0; cob_current_x = 0; return 0; @@ -4397,14 +4543,14 @@ cob_screen_set_mode (const cob_u32_t smode) if (!smode) { if (cobglobptr->cob_screen_initialized) { - wrefresh (mywin); + refresh_mywin (mywin); def_prog_mode (); endwin (); } } else { if (cobglobptr->cob_screen_initialized) { reset_prog_mode (); - wrefresh (mywin); + refresh_mywin (mywin); } else { cob_screen_init (); } @@ -4544,9 +4690,21 @@ cob_exit_screen (void) #if 0 /* CHECKME: Shouldn't be necessary */ wclear (mywin); cob_move_to_beg_of_last_line (); +#endif +#ifdef WITH_PANELS + for (;;) { + PANEL *ptr_pan = ceiling_panel (NULL); + if (ptr_pan) { + mywin = panel_window (ptr_pan); + del_panel (ptr_pan); + delwin (mywin); + } else { + break; + } + } #endif endwin (); /* ends curses' terminal mode */ - delwin (mywin); /* free storage related to screen not active */ + delwin (stdscr); /* free storage related to screen not active */ #ifdef HAVE_CURSES_FREEALL /* cleanup storage that would otherwise be shown to be "still reachable" with valgrind */ @@ -5124,3 +5282,682 @@ cob_init_screenio (cob_global *lptr, cob_settings *sptr) cob_settings_screenio (); } + +/* These functions are only defined if we have PANELS */ + +#ifdef WITH_PANELS + +/* Check the parms used for the panel functions */ +int +check_panel_parm (PPARM_FLD parm) +{ + if (mywin == stdscr) { + getyx (stdscr, save_cursor_y, save_cursor_x); + stdscr_fore_color = fore_color; + stdscr_back_color = back_color; + } + + parm->ret_code = 0; + switch (parm->mode) { + case CBL_NEW_WINDOW: + if (parm->starty > COB_MAX_Y_COORD) + parm->ret_code = 2; + if (parm->startx > COB_MAX_X_COORD) + parm->ret_code = 4; + if (parm->win_rows > COB_MAX_Y_COORD) + parm->ret_code = 6; + if (parm->win_cols > COB_MAX_X_COORD) + parm->ret_code = 7; + if (parm->bg_color < 0 || parm->bg_color > 15) + parm->ret_code = 8; + if (parm->fg_color < 0 || parm->fg_color > 15) + parm->ret_code = 9; + if (parm->fg_color == parm->bg_color) + parm->ret_code = 11; + break; + case CBL_DELETE_WINDOW: + if (parm->pan_number < 1 || parm->pan_number > MAX_PANELS) + parm->ret_code = 10; + break; + case CBL_MOVE_WINDOW: + if (parm->starty > COB_MAX_Y_COORD) + parm->ret_code = 2; + if (parm->startx > COB_MAX_X_COORD) + parm->ret_code = 4; + if (parm->pan_number < 1 || parm->pan_number > MAX_PANELS) + parm->ret_code = 10; + break; + case CBL_HIDE_WINDOW: + if (parm->pan_number < 1 || parm->pan_number > MAX_PANELS) + parm->ret_code = 10; + if (parm->hidden != 1 ) + parm->ret_code = 12; + break; + case CBL_SHOW_WINDOW: + if (parm->pan_number < 1 || parm->pan_number > MAX_PANELS) + parm->ret_code = 10; + if (parm->hidden != 0 ) + parm->ret_code = 14; + break; + case CBL_TOP_WINDOW: + if (parm->pan_number < 1 || parm->pan_number > MAX_PANELS) + parm->ret_code = 16; + break; + case CBL_BOTTOM_WINDOW: + if (parm->pan_number < 1 || parm->pan_number > MAX_PANELS) + parm->ret_code = 18; + break; + } + + return parm->ret_code; +} + +/* this function updates all the windows which are not hidden + and then does the final "doupdate" to update the physical screen */ +void +cob_update_all_windows (void) +{ + PANEL *ptr_pan; + WINDOW *ptr_win; + + /* first get the top panel */ + + ptr_pan =ceiling_panel(NULL); + + if (!ptr_pan) { + mywin = stdscr; + refresh_mywin (mywin); + doupdate (); + return; + } + + update_panels(); + + for(;ptr_pan;) { + ptr_win = panel_window (ptr_pan); + wnoutrefresh(ptr_win); + ptr_pan = panel_below(ptr_pan); + } + + refresh_mywin (mywin); + doupdate(); +} + +#endif + +/* CBL_GC_WINDOW - window functions */ +#ifdef COB_EXPERIMENTAL +int +cob_sys_window (unsigned char *a) +{ + +#ifndef WITH_PANELS + COB_UNUSED (a); + return -1; +#else + + cob_field *f1 = cob_get_param_field (1, "ANYPGM"); + PPARM_FLD parm; + PLIST_FLD list; + int ret; + + COB_CHK_PARMS (CBL_GC_NEW_WINDOW, 1); + init_cob_screen_if_needed (); + + if (f1->size == MAX_PANELS * sizeof (LIST_FLD)) { + list = a; + return (cob_list_window(list)); + } + + if (f1->size == sizeof (PARM_FLD)) { + parm = a; + ret = check_panel_parm(parm); + switch (ret) { + case 99: + return -4; + break; + case 0: + break; + default: + parm->ret_code = ret; + return -1; + break; + } + } else { + return -8; + } + + switch (parm->mode) { + case CBL_NEW_WINDOW: + return (cob_new_window (parm)); + break; + case CBL_DELETE_WINDOW: + return (cob_delete_window (parm)); + break; + case CBL_MOVE_WINDOW: + return (cob_move_window (parm)); + break; + case CBL_HIDE_WINDOW: + return (cob_hide_window (parm)); + break; + case CBL_SHOW_WINDOW: + return (cob_show_window (parm)); + break; + case CBL_TOP_WINDOW: + return (cob_top_window (parm)); + break; + case CBL_BOTTOM_WINDOW: + return (cob_bottom_window (parm)); + break; + default: + parm->ret_code = 44; + return -1; + break; + } +#endif + +} +#endif + + + +/* NEW_WINDOW - create a new panel / window pair */ +int +cob_new_window (PPARM_FLD parm) +{ + +#ifndef WITH_PANELS + COB_UNUSED (a); + return -1; +#else + + PPANEL_ENTRY pan_first = &my_panels[0]; + PPANEL_ENTRY pan_last = &my_panels[MAX_PANELS]; + PPANEL_ENTRY ptr_pan_entry; + PANEL *ptr_pan; + WINDOW *ptr_win; + short fg_color; + short bg_color; + short color_pr; + + init_cob_screen_if_needed (); + + /* find empty slot in panel array */ + + for(ptr_pan_entry = pan_first; ptr_pan_entry <= pan_last; ptr_pan_entry++) { + if (ptr_pan_entry->pan == NULL) + break; + } + + /* if no empty slot exists then set error code */ + + if (ptr_pan_entry > pan_last) { + parm->ret_code = 20; + return -1; + } + + ptr_win = newwin(parm->win_rows, + parm->win_cols, + parm->starty - 1, + parm->startx - 1); + if (!ptr_win) { + parm->ret_code = 22; + return -1; + } + + ptr_pan = new_panel(ptr_win); + if (!ptr_pan) { + parm->ret_code = 24; + return -1; + } + + cob_to_curses_color (parm->fg_color, &fg_color); + cob_to_curses_color (parm->bg_color, &bg_color); + + parm->pan_number = ptr_pan_entry->pan_number; + ptr_pan_entry->pan = ptr_pan; + ptr_pan_entry->win = ptr_win; + ptr_pan_entry->win_rows = parm->win_rows; + ptr_pan_entry->win_cols = parm->win_cols; + ptr_pan_entry->startx = parm->startx - 1; + ptr_pan_entry->starty = parm->starty - 1; + ptr_pan_entry->hidden = 0; + + if (set_panel_userptr (ptr_pan, ptr_pan_entry)) { + parm->ret_code = 26; + return -1; + } + + mywin = ptr_win; + + if (cobsetptr->cob_legacy) { + fg_color |= (parm->fg_color & 8); + bg_color |= (parm->bg_color & 8); + } + ptr_pan_entry->fg_color = fg_color; + ptr_pan_entry->bg_color = bg_color; + ptr_pan_entry->input_fg_color = parm->fg_color; + ptr_pan_entry->input_bg_color = parm->bg_color; + color_pr = cob_get_color_pair(fg_color, bg_color); + wbkgd (mywin ,COLOR_PAIR(color_pr)); + werase(mywin); + fore_color = fg_color; + back_color = bg_color; + cob_update_all_windows (); + return 0; +#endif +} + +/* MOVE_WINDOW - move the panel within stdscr */ +int +cob_move_window (PPARM_FLD parm) +{ + +#ifndef WITH_PANELS + COB_UNUSED (a); + return -1; +#else + + PPANEL_ENTRY ptr_pan_entry; + PANEL *ptr_pan; + + init_cob_screen_if_needed (); + + ptr_pan_entry = &my_panels[parm->pan_number - 1]; + if (!ptr_pan_entry->pan) { + parm->ret_code = 28; + return -1; + } + + ptr_pan = ptr_pan_entry->pan; + + if (!panel_hidden(ptr_pan_entry->pan)) { + parm->ret_code = 40; + return -1; + } + + if (move_panel (ptr_pan, + parm->starty - 1, + parm->startx - 1) ) { + parm->ret_code = 29; + return -1; + } + + ptr_pan_entry->startx = parm->startx - 1; + ptr_pan_entry->starty = parm->starty - 1; + + ptr_pan = ceiling_panel(NULL); + mywin = panel_window (ptr_pan); + ptr_pan_entry = (PPANEL_ENTRY)panel_userptr(ptr_pan); + fore_color = ptr_pan_entry->fg_color; + back_color = ptr_pan_entry->bg_color; + + parm->win_rows = ptr_pan_entry->win_rows; + parm->win_cols = ptr_pan_entry->win_cols; + parm->startx = ptr_pan_entry->startx + 1; + parm->starty = ptr_pan_entry->starty + 1; + parm->hidden = ptr_pan_entry->hidden; + parm->fg_color = ptr_pan_entry->input_fg_color; + parm->bg_color = ptr_pan_entry->input_bg_color; + + cob_update_all_windows (); + return 0; +#endif +} + +/* SHOW_WINDOW - show the panel within stdscr */ + +int +cob_show_window (PPARM_FLD parm) +{ + +#ifndef WITH_PANELS + COB_UNUSED (a); + return -1; +#else + + PPANEL_ENTRY ptr_pan_entry; + PANEL *ptr_pan; + + init_cob_screen_if_needed (); + + ptr_pan_entry = &my_panels[parm->pan_number - 1]; + if (!ptr_pan_entry->pan) { + parm->ret_code = 28; + return -1; + } + + if (panel_hidden(ptr_pan_entry->pan)) { + parm->ret_code = 42; + return -1; + } + + ptr_pan = ptr_pan_entry->pan; + + if (show_panel(ptr_pan)) { + parm->ret_code = 30; + return -1; + } + + ptr_pan_entry->hidden = 0; + + ptr_pan = ceiling_panel(NULL); + mywin = panel_window (ptr_pan); + ptr_pan_entry = (PPANEL_ENTRY)panel_userptr(ptr_pan); + fore_color = ptr_pan_entry->fg_color; + back_color = ptr_pan_entry->bg_color; + + parm->win_rows = ptr_pan_entry->win_rows; + parm->win_cols = ptr_pan_entry->win_cols; + parm->startx = ptr_pan_entry->startx + 1; + parm->starty = ptr_pan_entry->starty + 1; + parm->hidden = ptr_pan_entry->hidden; + parm->fg_color = ptr_pan_entry->input_fg_color; + parm->bg_color = ptr_pan_entry->input_bg_color; + + cob_update_all_windows (); + return 0; +#endif +} + +/* HIDE_WINDOW - hide the panel within stdscr */ +int +cob_hide_window (PPARM_FLD parm) +{ + +#ifndef WITH_PANELS + COB_UNUSED (a); + return -1; +#else + + PPANEL_ENTRY ptr_pan_entry; + PANEL *ptr_pan; + + init_cob_screen_if_needed (); + + ptr_pan_entry = &my_panels[parm->pan_number - 1]; + if (!ptr_pan_entry->pan) { + parm->ret_code = 28; + return -1; + } + + ptr_pan = ptr_pan_entry->pan; + + if (!panel_hidden(ptr_pan_entry->pan)) { + parm->ret_code = 40; + return -1; + } + + if (hide_panel(ptr_pan)) { + parm->ret_code = 32; + return -1; + } + + ptr_pan_entry->hidden = 1; + + /* note the following is needed in case the top panel + was hidden. then the next panel will be on top */ + + ptr_pan = ceiling_panel(NULL); + + if (ptr_pan) { + mywin = panel_window (ptr_pan); + ptr_pan_entry = (PPANEL_ENTRY)panel_userptr(ptr_pan); + fore_color = ptr_pan_entry->fg_color; + back_color = ptr_pan_entry->bg_color; + } else { + mywin = stdscr; + move(save_cursor_y, save_cursor_x); + fore_color = stdscr_fore_color; + back_color = stdscr_back_color; + } + + parm->win_rows = ptr_pan_entry->win_rows; + parm->win_cols = ptr_pan_entry->win_cols; + parm->startx = ptr_pan_entry->startx + 1; + parm->starty = ptr_pan_entry->starty + 1; + parm->hidden = ptr_pan_entry->hidden; + parm->fg_color = ptr_pan_entry->input_fg_color; + parm->bg_color = ptr_pan_entry->input_bg_color; + + cob_update_all_windows (); + return 0; +#endif +} + + +/* TOP_WINDOW - top the panel within stdscr */ +int +cob_top_window (PPARM_FLD parm) +{ + +#ifndef WITH_PANELS + COB_UNUSED (a); + return -1; +#else + + PPANEL_ENTRY ptr_pan_entry; + PANEL *ptr_pan; + + init_cob_screen_if_needed (); + + ptr_pan_entry = &my_panels[parm->pan_number - 1]; + if (!ptr_pan_entry->pan) { + parm->ret_code = 28; + return -1; + } + + ptr_pan = ptr_pan_entry->pan; + + if (!panel_hidden(ptr_pan_entry->pan)) { + parm->ret_code = 40; + return -1; + } + + if (top_panel(ptr_pan)) { + parm->ret_code = 34; + return -1; + } + + ptr_pan = ceiling_panel(NULL); + mywin = panel_window (ptr_pan); + ptr_pan_entry = (PPANEL_ENTRY)panel_userptr(ptr_pan); + fore_color = ptr_pan_entry->fg_color; + back_color = ptr_pan_entry->bg_color; + + parm->win_rows = ptr_pan_entry->win_rows; + parm->win_cols = ptr_pan_entry->win_cols; + parm->startx = ptr_pan_entry->startx + 1; + parm->starty = ptr_pan_entry->starty + 1; + parm->hidden = ptr_pan_entry->hidden; + parm->fg_color = ptr_pan_entry->input_fg_color; + parm->bg_color = ptr_pan_entry->input_bg_color; + + cob_update_all_windows (); + return 0; +#endif +} + + +/* BOTTOM_WINDOW - top the panel within stdscr */ +int +cob_bottom_window (PPARM_FLD parm) +{ + +#ifndef WITH_PANELS + COB_UNUSED (a); + return -1; +#else + + PPANEL_ENTRY ptr_pan_entry; + PANEL *ptr_pan; + + init_cob_screen_if_needed (); + + ptr_pan_entry = &my_panels[parm->pan_number - 1]; + if (!ptr_pan_entry->pan) { + parm->ret_code = 28; + return -1; + } + + ptr_pan = ptr_pan_entry->pan; + + if (!panel_hidden(ptr_pan_entry->pan)) { + parm->ret_code = 40; + return -1; + } + + if (bottom_panel(ptr_pan)) { + parm->ret_code = 35; + return -1; + } + + ptr_pan = ceiling_panel(NULL); + ptr_pan_entry = (PPANEL_ENTRY)panel_userptr(ptr_pan); + mywin = panel_window (ptr_pan); + parm->pan_number = ptr_pan_entry->pan_number; + fore_color = ptr_pan_entry->fg_color; + back_color = ptr_pan_entry->bg_color; + + parm->win_rows = ptr_pan_entry->win_rows; + parm->win_cols = ptr_pan_entry->win_cols; + parm->startx = ptr_pan_entry->startx + 1; + parm->starty = ptr_pan_entry->starty + 1; + parm->hidden = ptr_pan_entry->hidden; + parm->fg_color = ptr_pan_entry->input_fg_color; + parm->bg_color = ptr_pan_entry->input_bg_color; + + cob_update_all_windows (); + return 0; +#endif +} + +/* DELETE_WINDOW - delete the panel within stdscr */ +int +cob_delete_window (PPARM_FLD parm) +{ + +#ifndef WITH_PANELS + COB_UNUSED (a); + return -1; +#else + + PPANEL_ENTRY ptr_pan_entry; + PANEL *ptr_pan; + + init_cob_screen_if_needed (); + + ptr_pan_entry = &my_panels[parm->pan_number - 1]; + if (!ptr_pan_entry->pan) { + parm->ret_code = 28; + return -1; + } + + if (!panel_hidden(ptr_pan_entry->pan)) { + show_panel( ptr_pan_entry->pan); + } + + if (del_panel(ptr_pan_entry->pan)) { + parm->ret_code = 38; + } + + if (delwin(ptr_pan_entry->win)) { + parm->ret_code = 36; + } + + if (parm->ret_code) { + return -1; + } + + ptr_pan_entry->pan = NULL; + ptr_pan_entry->win = NULL; + ptr_pan_entry->win_rows = 0; + ptr_pan_entry->win_cols = 0; + ptr_pan_entry->startx = 0; + ptr_pan_entry->starty = 0; + ptr_pan_entry->hidden = 0; + ptr_pan_entry->fg_color = 0; + ptr_pan_entry->bg_color = 7; + ptr_pan_entry->input_fg_color = 0; + ptr_pan_entry->input_bg_color = 7; + + ptr_pan = ceiling_panel(NULL); + + if (ptr_pan) { + mywin = panel_window (ptr_pan); + ptr_pan_entry = (PPANEL_ENTRY)panel_userptr(ptr_pan); + fore_color = ptr_pan_entry->fg_color; + back_color = ptr_pan_entry->bg_color; + } else { + mywin = stdscr; + move(save_cursor_y, save_cursor_x); + fore_color = stdscr_fore_color; + back_color = stdscr_back_color; + } + + parm->win_rows = ptr_pan_entry->win_rows; + parm->win_cols = ptr_pan_entry->win_cols; + parm->startx = ptr_pan_entry->startx + 1; + parm->starty = ptr_pan_entry->starty + 1; + parm->hidden = ptr_pan_entry->hidden; + parm->fg_color = ptr_pan_entry->input_fg_color; + parm->bg_color = ptr_pan_entry->input_bg_color; + + cob_update_all_windows (); + return 0; +#endif +} + + +/* LIST_WINDOW - list all of the windows */ +int +cob_list_window (PLIST_FLD list) +{ + +#ifndef WITH_PANELS + COB_UNUSED (a); + return -1; +#else + + PPANEL_ENTRY ptr_pan_entry; + PANEL *ptr_pan; + int depth, loop; + + depth = 1; + memset(list, 0, MAX_PANELS * sizeof(LIST_FLD)); + ptr_pan = ceiling_panel(NULL); + + while (ptr_pan) { + ptr_pan_entry = (PPANEL_ENTRY)panel_userptr(ptr_pan); + list->pan_position = depth; + list->pan_number = ptr_pan_entry->pan_number; + list->win_rows = ptr_pan_entry->win_rows; + list->win_cols = ptr_pan_entry->win_cols; + list->startx = ptr_pan_entry->startx + 1; + list->starty = ptr_pan_entry->starty + 1; + list->hidden = ptr_pan_entry->hidden; + list->input_fg_color = ptr_pan_entry->input_fg_color; + list->input_bg_color = ptr_pan_entry->input_bg_color; + list++; + depth++; + ptr_pan = panel_below (ptr_pan); + } + ptr_pan_entry = &my_panels[0]; + + for(loop = 0; loop < MAX_PANELS; loop++, ptr_pan_entry++) { + if (ptr_pan_entry->hidden) { + list->pan_position = 0; + list->pan_number = ptr_pan_entry->pan_number; + list->win_rows = ptr_pan_entry->win_rows; + list->win_cols = ptr_pan_entry->win_cols; + list->startx = ptr_pan_entry->startx + 1; + list->starty = ptr_pan_entry->starty + 1; + list->hidden = ptr_pan_entry->hidden; + list->input_fg_color = ptr_pan_entry->input_fg_color; + list->input_bg_color = ptr_pan_entry->input_bg_color; + list++; + } + } + return 0; +#endif +} diff --git a/libcob/system.def b/libcob/system.def index 969dd2b78..6eae2b3f1 100644 --- a/libcob/system.def +++ b/libcob/system.def @@ -1,5 +1,5 @@ /* - Copyright (C) 2006-2012, 2014, 2016-2019, 2022-2023 Free Software Foundation, Inc. + Copyright (C) 2006-2012, 2014, 2016-2019, 2022-2024 Free Software Foundation, Inc. Written by Roger While, Simon Sobisch, Ron Norman This file is part of GnuCOBOL. @@ -43,7 +43,10 @@ COB_SYSTEM_GEN ("CBL_GET_CSR_POS", 1, 1, cob_sys_get_csr_pos) COB_SYSTEM_GEN ("CBL_GET_CURRENT_DIR", 3, 3, cob_sys_get_current_dir) COB_SYSTEM_GEN ("CBL_GET_SCR_SIZE", 2, 2, cob_sys_get_scr_size) COB_SYSTEM_GEN ("CBL_GC_SCR_DUMP", 1, 1, cob_sys_scr_dump) -COB_SYSTEM_GEN ("CBL_GC_SCR_RESTORE", 1, 1, cob_sys_scr_restore) +COB_SYSTEM_GEN ("CBL_GC_SCR_RESTORE", 1, 1, cob_sys_scr_restore) +#ifdef COB_EXPERIMENTAL +COB_SYSTEM_GEN ("CBL_GC_WINDOW", 1, 1, cob_sys_window) +#endif COB_SYSTEM_GEN ("CBL_IMP", 3, 3, cob_sys_imp) COB_SYSTEM_GEN ("CBL_NIMP", 3, 3, cob_sys_nimp) COB_SYSTEM_GEN ("CBL_NOR", 3, 3, cob_sys_nor) diff --git a/tests/testsuite.src/run_manual_screen.at b/tests/testsuite.src/run_manual_screen.at index 2c6596b7d..d9334d56f 100644 --- a/tests/testsuite.src/run_manual_screen.at +++ b/tests/testsuite.src/run_manual_screen.at @@ -1,3815 +1,4208 @@ -## Copyright (C) 2014-2018,2020-2024 Free Software Foundation, Inc. -## Written by Edward Hart, Simon Sobisch -## -## This file is part of GnuCOBOL. -## -## The GnuCOBOL compiler is free software: you can redistribute it -## and/or modify it under the terms of the GNU General Public License -## as published by the Free Software Foundation, either version 3 of the -## License, or (at your option) any later version. -## -## GnuCOBOL is distributed in the hope that it will be useful, -## but WITHOUT ANY WARRANTY; without even the implied warranty of -## MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -## GNU General Public License for more details. -## -## You should have received a copy of the GNU General Public License -## along with GnuCOBOL. If not, see . - -### GnuCOBOL Test Suite - -### ISO+IEC+1989-2014 9.2 Screens, 13.17 Screen description entry, 13.18 Data -### division clauses. - -AT_SETUP([LINE]) -AT_KEYWORDS([screen]) - -AT_SKIP_IF([test "$COB_HAS_CURSES" != "yes"]) - -AT_DATA([prog.cob], [ - IDENTIFICATION DIVISION. - PROGRAM-ID. prog. - DATA DIVISION. - WORKING-STORAGE SECTION. - 01 success-flag PIC X VALUE 'Y'. - 88 success VALUE 'Y', 'y'. - - SCREEN SECTION. - 01 scr. - 03 LINE 1 VALUE 'Enter "y" if the numbers below correspond ' - & 'to their line number and are in the '. - 03 LINE 2 VALUE 'first column. (This is line 2.)'. - 03 LINE 3 VALUE '3'. - 03 LINE 4 VALUE '4'. - 03 LINE 5 VALUE '5'. - 03 group-1 LINE - 3. - 05 group-2 COL 5. - 07 LINE PLUS 6 VALUE '8'. - 07 LINE MINUS 2 VALUE '6'. - 03 group-3 LINE + 1. - 05 COL 1 VALUE '7'. - 03 LINE + 3 PIC X, REQUIRED USING success-flag. - - PROCEDURE DIVISION. - DISPLAY scr - ACCEPT scr - - IF success AND COB-CRT-STATUS = 0 - GOBACK RETURNING 0 - ELSE - GOBACK RETURNING 1 - END-IF - . -]) - -AT_CHECK([$COMPILE prog.cob], [0], [], []) -MANUAL_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) - -AT_CLEANUP - - -AT_SETUP([COLUMN (1)]) -AT_KEYWORDS([COL]) - -AT_SKIP_IF([test "$COB_HAS_CURSES" != "yes"]) - -AT_DATA([prog.cob], [ - IDENTIFICATION DIVISION. - PROGRAM-ID. prog. - DATA DIVISION. - WORKING-STORAGE SECTION. - 01 dummy PIC X(5). - 01 success-flag PIC X VALUE 'Y'. - 88 success VALUE 'Y', 'y'. - - SCREEN SECTION. - 01 scr. - 03 VALUE 'Enter "y" if the numbers below correspond to ' - & 'their column number.'. - 03 LINE 2 VALUE '123456789'. - 03 LINE 3 COLUMN 2. - 05 COL 1 VALUE '1'. - 05 COL 5 VALUE '5'. - 05 COL MINUS 2 VALUE '3'. - 05 COL PLUS 1 VALUE '4'. - 05 group-1 LINE 3. - 07 VALUE '2'. - 07 group-2 COLUMN + 4. - 09 group-3. - 11 COL + 0 VALUE '6'. - 05 COLUMN + 1, VALUE '7'. - 03 LINE 5 PIC X, REQUIRED, USING success-flag. - - PROCEDURE DIVISION. - DISPLAY scr - ACCEPT scr - - IF success AND COB-CRT-STATUS = 0 - GOBACK RETURNING 0 - ELSE - GOBACK RETURNING 1 - END-IF - . -]) - -AT_CHECK([$COMPILE prog.cob], [0], [], []) -MANUAL_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) - -AT_CLEANUP - - -AT_SETUP([COLUMN (2)]) -AT_KEYWORDS([COL]) - -AT_SKIP_IF([test "$COB_HAS_CURSES" != "yes"]) - -AT_DATA([prog.cob], [ - IDENTIFICATION DIVISION. - PROGRAM-ID. prog. - - DATA DIVISION. - WORKING-STORAGE SECTION. - 01 dummy-1 PIC X(10). - 01 dummy-2 PIC X(10). - 01 dummy-3 PIC X(10). - - 01 success-flag PIC X VALUE 'Y'. - 88 success VALUE 'Y', 'y'. - - SCREEN SECTION. - 01 scr. - 03 PIC X(80) VALUE 'Enter "y" if there are three non-'- - 'overlapping input fields on one line below.'. - 03 LINE + 1, PIC X(80) VALUE 'field.'. - 03 LINE + 2, PIC X(10) TO dummy-1. - 03 COL + 2, PIC X(10) TO dummy-2. - 03 COL + 2, PIC X(10) TO dummy-3. - 03 success-field LINE + 2, PIC X, REQUIRED, - USING success-flag. - - PROCEDURE DIVISION. - DISPLAY scr - ACCEPT scr - - IF success AND COB-CRT-STATUS = 0 - GOBACK RETURNING 0 - ELSE - GOBACK RETURNING 1 - END-IF - . -]) - -AT_CHECK([$COMPILE prog.cob], [0], [], []) -MANUAL_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) - -AT_CLEANUP - - -AT_SETUP([LINE non-zero, COLUMN zero]) -AT_KEYWORDS([COL extensions]) - -AT_SKIP_IF([test "$COB_HAS_CURSES" != "yes"]) - -AT_DATA([prog.cob], [ - IDENTIFICATION DIVISION. - PROGRAM-ID. prog. - DATA DIVISION. - WORKING-STORAGE SECTION. - 01 success-flag PIC X VALUE 'Y'. - 88 success VALUE 'Y', 'y'. - - SCREEN SECTION. - 01 scr. - 03 LINE 1 VALUE 'Enter "y" if you see 123 on the line '- - 'below starting at column 1.'. - 03 LINE + 3 PIC X, REQUIRED USING success-flag. - 03 LINE 2 VALUE '1'. - - PROCEDURE DIVISION. - DISPLAY scr - DISPLAY '2' LINE 2, COLUMN 0; '3' - ACCEPT scr - - IF success AND COB-CRT-STATUS = 0 - GOBACK RETURNING 0 - ELSE - GOBACK RETURNING 1 - END-IF - . -]) - -AT_CHECK([$COMPILE prog.cob], [0], [], []) -MANUAL_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) - -AT_CLEANUP - - -AT_SETUP([LINE zero, COLUMN non-zero]) -AT_KEYWORDS([COL zero extensions]) - -AT_SKIP_IF([test "$COB_HAS_CURSES" != "yes"]) - -AT_DATA([prog.cob], [ - IDENTIFICATION DIVISION. - PROGRAM-ID. prog. - DATA DIVISION. - WORKING-STORAGE SECTION. - 01 success-flag PIC X VALUE 'Y'. - 88 success VALUE 'Y', 'y'. - - SCREEN SECTION. - 01 scr. - 03 LINE 1 VALUE 'Enter "y" if you see 123 on the line '- - 'below starting at column 1.'. - 03 LINE + 3 PIC X, REQUIRED USING success-flag. - 03 LINE 2 COL 3, VALUE '3'. - 03 LINE 1 COL 80 VALUE ' '. - - PROCEDURE DIVISION. - DISPLAY scr - DISPLAY '1' LINE 0, COLUMN 1; '2' - ACCEPT scr - - IF success AND COB-CRT-STATUS = 0 - GOBACK RETURNING 0 - ELSE - GOBACK RETURNING 1 - END-IF - . -]) - -AT_CHECK([$COMPILE prog.cob], [0], [], []) -MANUAL_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) - -AT_CLEANUP - - -AT_SETUP([LINE zero, COLUMN zero]) -AT_KEYWORDS([COL extensions]) - -AT_SKIP_IF([test "$COB_HAS_CURSES" != "yes"]) - -AT_DATA([prog.cob], [ - IDENTIFICATION DIVISION. - PROGRAM-ID. prog. - DATA DIVISION. - WORKING-STORAGE SECTION. - 01 success-flag PIC X VALUE 'Y'. - 88 success VALUE 'Y', 'y'. - - SCREEN SECTION. - 01 scr. - 03 LINE 1 VALUE 'Enter "y" if you see 1234 on the line '- - 'below starting at column 1.'. - 03 LINE + 3 PIC X, REQUIRED USING success-flag. - 03 LINE 2 VALUE '1'. - - PROCEDURE DIVISION. - DISPLAY scr - DISPLAY '2' LINE 0, COLUMN 0 - DISPLAY '3' LINE 2, COLUMN 3 - DISPLAY '4' AT 0000 - - ACCEPT scr - - IF success AND COB-CRT-STATUS = 0 - GOBACK RETURNING 0 - ELSE - GOBACK RETURNING 1 - END-IF - . -]) - -AT_CHECK([$COMPILE prog.cob], [0], [], []) -MANUAL_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) - -AT_CLEANUP - - -AT_SETUP([DISPLAY AT]) -AT_KEYWORDS([extensions]) - -AT_SKIP_IF([test "$COB_HAS_CURSES" != "yes"]) - -AT_DATA([prog.cob], [ - IDENTIFICATION DIVISION. - PROGRAM-ID. prog. - DATA DIVISION. - WORKING-STORAGE SECTION. - 01 success-flag PIC X VALUE 'Y'. - 88 success VALUE 'Y', 'y'. - - 01 screen-loc PIC 9(6) VALUE 4004. - - SCREEN SECTION. - 01 scr. - 03 VALUE 'Enter "y" if the numbers 1-3 are in a diagonal'- - ' line from line 2, column 2.'. - 03 success-field PIC X, LINE 6, REQUIRED, - USING success-flag. - - PROCEDURE DIVISION. - DISPLAY '1' AT 0202 - DISPLAY '2' AT 003003 - DISPLAY '3' AT screen-loc - DISPLAY scr - ACCEPT scr - - IF success AND COB-CRT-STATUS = 0 - GOBACK RETURNING 0 - ELSE - GOBACK RETURNING 1 - END-IF - . -]) - -AT_CHECK([$COMPILE prog.cob], [0], [], []) -MANUAL_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) - -AT_CLEANUP - - -AT_SETUP([DISPLAY LOW-VALUES (one statement)]) -AT_KEYWORDS([LOW-VALUE extensions]) - -AT_SKIP_IF([test "$COB_HAS_CURSES" != "yes"]) - -AT_DATA([prog.cob], [ - IDENTIFICATION DIVISION. - PROGRAM-ID. prog. - DATA DIVISION. - WORKING-STORAGE SECTION. - 01 success-flag PIC X VALUE 'Y'. - 88 success VALUE 'Y', 'y'. - - SCREEN SECTION. - 01 scr. - 03 LINE 1 VALUE 'Enter "y" if the word below starts at line' - & ' 3, column 3.'. - 03 LINE + 4 PIC X, REQUIRED USING success-flag. - - PROCEDURE DIVISION. - DISPLAY scr - DISPLAY LOW-VALUES AT LINE 3, COL 3; 'Hello!' - ACCEPT scr - - IF success AND COB-CRT-STATUS = 0 - GOBACK RETURNING 0 - ELSE - GOBACK RETURNING 1 - END-IF - . -]) - -AT_CHECK([$COMPILE prog.cob], [0], [], []) -MANUAL_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) - -AT_CLEANUP - - -AT_SETUP([DISPLAY LOW-VALUES (two statements)]) -AT_KEYWORDS([LOW-VALUE extensions]) - -AT_SKIP_IF([test "$COB_HAS_CURSES" != "yes"]) - -AT_DATA([prog.cob], [ - IDENTIFICATION DIVISION. - PROGRAM-ID. prog. - DATA DIVISION. - WORKING-STORAGE SECTION. - 01 success-flag PIC X VALUE 'Y'. - 88 success VALUE 'Y', 'y'. - - SCREEN SECTION. - 01 scr. - 03 LINE 1 VALUE 'Enter "y" if the word below starts at line' - & ' 3, column 3.'. - 03 LINE + 4 PIC X, REQUIRED USING success-flag. - - PROCEDURE DIVISION. - DISPLAY scr - DISPLAY LOW-VALUES AT LINE 3, COL 3 - DISPLAY 'Hello!' UPON CRT - ACCEPT scr - - IF success AND COB-CRT-STATUS = 0 - GOBACK RETURNING 0 - ELSE - GOBACK RETURNING 1 - END-IF - . -]) - -AT_CHECK([$COMPILE prog.cob], [0], [], []) -MANUAL_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) - -AT_CLEANUP - - -AT_SETUP([DISPLAY SPACES]) -AT_KEYWORDS([SPACE extensions]) - -AT_SKIP_IF([test "$COB_HAS_CURSES" != "yes"]) - -AT_DATA([prog.cob], [ - IDENTIFICATION DIVISION. - PROGRAM-ID. prog. - - DATA DIVISION. - WORKING-STORAGE SECTION. - 01 success-flag PIC X VALUE 'Y'. - 88 success VALUE 'Y', 'y'. - - SCREEN SECTION. - 01 scr-1. - 03 LINE 1 VALUE 'Enter "y" if all the text after foo in the' - & ' screen has been erased.'. - 03 LINE 3 VALUE 'Lorem ipsum dolor sit amet, consectetur ad' - & 'ipiscing elit. Curabitur dapibus dui'. - 03 LINE 4 VALUE 'vitae augue lobortis, non tempor diam tris' - & 'tique. Donec dignissim ex velit, ut'. - 03 LINE 5 VALUE 'efficitur tellus pharetra at. Curabitur at' - & ' condimentum nunc, nec accumsan'. - 03 LINE 6 VALUE 'nulla. Nulla at feugiat elit, eget condime' - & 'ntum justo. Nam lorem lectus,'. - 03 LINE 7 VALUE 'imperdiet sit amet odio eu, eleifend conse' - & 'ctetur ligula. Duis diam felis, porta'. - 03 LINE 8 VALUE 'id diam id, ultrices finibus augue. Mauris' - & ' imperdiet, dolor sed sodales porta,'. - 03 LINE 9 VALUE 'justo nunc consequat nulla, iaculis venena' - & 'tis lorem libero sit amet'. - 03 LINE 10 VALUE 'magna. Nullam pulvinar nullam.'. - 03 success-field LINE + 2, PIC X, REQUIRED, - USING success-flag. - - PROCEDURE DIVISION. - DISPLAY scr-1 - DISPLAY SPACES AT LINE 6, COL 8; 'foo' HIGHLIGHT - ACCEPT success-field - - IF success AND COB-CRT-STATUS = 0 - GOBACK RETURNING 0 - ELSE - GOBACK RETURNING 1 - END-IF - . -]) - -AT_CHECK([$COMPILE -fdisplay-special-fig-consts prog.cob], [0], [], []) -MANUAL_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) - -AT_CLEANUP - - -AT_SETUP([DISPLAY ALL X'01']) -AT_KEYWORDS([SOH extensions]) - -AT_SKIP_IF([test "$COB_HAS_CURSES" != "yes"]) - -AT_DATA([prog.cob], [ - IDENTIFICATION DIVISION. - PROGRAM-ID. prog. - - DATA DIVISION. - WORKING-STORAGE SECTION. - 01 success-flag PIC X VALUE 'Y'. - 88 success VALUE 'Y', 'y'. - - SCREEN SECTION. - 01 scr-1. - 03 LINE 1 VALUE 'Enter "y" if all the text after foo on ' - & 'that line alone has been erased.'. - 03 LINE 3 VALUE 'Lorem ipsum dolor sit amet, consectetur ad' - & 'ipiscing elit. Curabitur dapibus dui'. - 03 LINE 4 VALUE 'vitae augue lobortis, non tempor diam tris' - & 'tique. Donec dignissim ex velit, ut'. - 03 LINE 5 VALUE 'efficitur tellus pharetra at. Curabitur at' - & ' condimentum nunc, nec accumsan'. - 03 LINE 6 VALUE 'nulla. Nulla at feugiat elit, eget condime' - & 'ntum justo. Nam lorem lectus,'. - 03 LINE 7 VALUE 'imperdiet sit amet odio eu, eleifend conse' - & 'ctetur ligula. Duis diam felis, porta'. - 03 LINE 8 VALUE 'id diam id, ultrices finibus augue. Mauris' - & ' imperdiet, dolor sed sodales porta,'. - 03 LINE 9 VALUE 'justo nunc consequat nulla, iaculis venena' - & 'tis lorem libero sit amet'. - 03 LINE 10 VALUE 'magna. Nullam pulvinar nullam.'. - 03 success-field LINE + 2, PIC X, REQUIRED, - USING success-flag. - - PROCEDURE DIVISION. - DISPLAY scr-1 - DISPLAY ALL X'01', LINE 6, COLUMN 8; 'foo' HIGHLIGHT - ACCEPT success-field - - IF success AND COB-CRT-STATUS = 0 - GOBACK RETURNING 0 - ELSE - GOBACK RETURNING 1 - END-IF - . -]) - -AT_CHECK([$COMPILE -fdisplay-special-fig-consts prog.cob], [0], [], []) -MANUAL_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) - -AT_CLEANUP - - -AT_SETUP([DISPLAY ALL X'02']) -AT_KEYWORDS([STX extensions]) - -AT_SKIP_IF([test "$COB_HAS_CURSES" != "yes"]) - -AT_DATA([prog.cob], [ - IDENTIFICATION DIVISION. - PROGRAM-ID. prog. - - DATA DIVISION. - WORKING-STORAGE SECTION. - 01 success-flag PIC X VALUE 'Y'. - 88 success VALUE 'Y', 'y'. - - SCREEN SECTION. - 01 scr-1. - 03 LINE 3 VALUE 'Lorem ipsum dolor sit amet, consectetur ad' - & 'ipiscing elit. Curabitur dapibus dui'. - 03 LINE 4 VALUE 'vitae augue lobortis, non tempor diam tris' - & 'tique. Donec dignissim ex velit, ut'. - 03 LINE 5 VALUE 'efficitur tellus pharetra at. Curabitur at' - & ' condimentum nunc, nec accumsan'. - 03 LINE 6 VALUE 'nulla. Nulla at feugiat elit, eget condime' - & 'ntum justo. Nam lorem lectus,'. - 03 LINE 7 VALUE 'imperdiet sit amet odio eu, eleifend conse' - & 'ctetur ligula. Duis diam felis, porta'. - 03 LINE 8 VALUE 'id diam id, ultrices finibus augue. Mauris' - & ' imperdiet, dolor sed sodales porta,'. - 03 LINE 9 VALUE 'justo nunc consequat nulla, iaculis venena' - & 'tis lorem libero sit amet'. - 03 LINE 10 VALUE 'magna. Nullam pulvinar nullam.'. - - 01 scr-2. - 03 LINE 6 COL 8 VALUE 'foo' BLANK SCREEN, HIGHLIGHT. - 03 LINE 1 VALUE 'Enter "y" if foo is the only word below.'. - - 01 scr-3. - 03 VALUE 'Enter "y" if foo is the only word below.'. - 03 success-field COL + 2, PIC X, REQUIRED, - USING success-flag. - - PROCEDURE DIVISION. - DISPLAY scr-1 - DISPLAY ALL X'02' AT LINE 6 COL 8; 'foo' HIGHLIGHT - DISPLAY scr-3 - ACCEPT scr-3 - - IF success AND COB-CRT-STATUS = 0 - GOBACK RETURNING 0 - ELSE - GOBACK RETURNING 1 - END-IF - . -]) - -AT_CHECK([$COMPILE -fdisplay-special-fig-consts prog.cob], [0], [], []) -MANUAL_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) - -AT_CLEANUP - - -AT_SETUP([DISPLAY ALL X'07']) -AT_KEYWORDS([BELL BEEP extensions]) - -AT_SKIP_IF([test "$COB_HAS_CURSES" != "yes"]) - -AT_DATA([prog.cob], [ - IDENTIFICATION DIVISION. - PROGRAM-ID. prog. - DATA DIVISION. - WORKING-STORAGE SECTION. - 01 success-flag PIC X. - 88 success VALUE 'Y', 'y'. - - SCREEN SECTION. - 01 scr. - 03 VALUE 'Enter "y" if you heard a beep:'. - 03 success-field PIC X, COL + 2, REQUIRED, TO success-flag - FROM 'Y'. - 01 scr2. - 03 LINE 4 VALUE 'system beep may be turned off ' & - 'on this system.'. - 03 LINE 5 VALUE 'Retesting with COB_BELL=FLASH...'. - 03 LINE + 2 - VALUE 'Enter "y" if you''ve seen your terminal flash'. - 03 success-field PIC X, COL + 2, REQUIRED, TO success-flag - FROM 'Y'. - - PROCEDURE DIVISION. - DISPLAY scr - DISPLAY ALL X'07' UPON CRT - ACCEPT scr - - IF success AND COB-CRT-STATUS = 0 - GOBACK RETURNING 0 - END-IF - - SET ENVIRONMENT 'COB_BELL' TO 'FLASH' - CALL 'C$SLEEP' USING '1' - - DISPLAY scr2 - DISPLAY ALL X'07' UPON CRT - ACCEPT scr2 - - IF success AND COB-CRT-STATUS = 0 - GOBACK RETURNING 0 - ELSE - GOBACK RETURNING 1 - END-IF - . -]) - -AT_CHECK([$COMPILE -fdisplay-special-fig-consts prog.cob], [0], [], []) -MANUAL_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) - -AT_CLEANUP - - -AT_SETUP([Screen position after field display]) -AT_KEYWORDS([LINE COLUMN]) - -AT_SKIP_IF([test "$COB_HAS_CURSES" != "yes"]) - -AT_DATA([prog.cob], [ - IDENTIFICATION DIVISION. - PROGRAM-ID. prog. - DATA DIVISION. - WORKING-STORAGE SECTION. - 01 success-flag PIC X VALUE 'Y'. - 88 success VALUE 'Y', 'y'. - - SCREEN SECTION. - 01 scr. - 03 VALUE 'Enter "y" if this sentence starts at line 1,'- - ' column 1:'. - 03 success-field PIC X, COL + 2, REQUIRED, - USING success-flag. - - PROCEDURE DIVISION. - DISPLAY 'ignore this' AT LINE 4 COL 4 - DISPLAY scr - ACCEPT success-field - - IF success AND COB-CRT-STATUS = 0 - GOBACK RETURNING 0 - ELSE - GOBACK RETURNING 1 - END-IF - . -]) - -AT_CHECK([$COMPILE prog.cob], [0], [], []) -MANUAL_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) - -AT_CLEANUP - -# See section 13.17.3 - -AT_SETUP([Overridden clauses (1)]) -AT_KEYWORDS([LINE COLUMN COL]) - -AT_SKIP_IF([test "$COB_HAS_CURSES" != "yes"]) - -AT_DATA([prog.cob], [ - IDENTIFICATION DIVISION. - PROGRAM-ID. prog. - DATA DIVISION. - WORKING-STORAGE SECTION. - 01 dummy PIC X(5). - 01 success-flag PIC X VALUE 'Y'. - 88 success VALUE 'Y', 'y'. - - SCREEN SECTION. - 01 scr. - 03 VALUE 'Enter "y" if the numbers below correspond to their' - & ' column number and all on'. - 03 LINE 2 VALUE 'lines 3 and 4.'. - 03 LINE 3 VALUE '123456789'. - 03 LINE 4 VALUE ' 34'. - 03 FILLER LINE + 6. - 05 COL 3. - 07 COL 1. - 09 LINE 4 VALUE '1'. - 09 VALUE '2'. - 05 LINE + 1, COL + 2. - 07 LINE 4, COL + 1, VALUE '5'. - 03 LINE 6 PIC X, REQUIRED, USING success-flag. - - PROCEDURE DIVISION. - DISPLAY scr - ACCEPT scr - - IF success AND COB-CRT-STATUS = 0 - GOBACK RETURNING 0 - ELSE - GOBACK RETURNING 1 - END-IF - . -]) - -AT_CHECK([$COMPILE prog.cob], [0], [], []) -MANUAL_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) - -AT_CLEANUP - - -AT_SETUP([Overridden clauses (2)]) -AT_KEYWORDS([HIGHLIGHT LOWLIGHT BACKGROUND COLOR COLOUR]) - -AT_SKIP_IF([test "$COB_HAS_CURSES" != "yes"]) - -AT_DATA([prog.cob], [ - IDENTIFICATION DIVISION. - PROGRAM-ID. prog. - DATA DIVISION. - WORKING-STORAGE SECTION. - 01 dummy PIC X(5). - 01 success-flag PIC X VALUE 'Y'. - 88 success VALUE 'Y', 'y'. - - SCREEN SECTION. - 01 scr. - 03 VALUE 'Enter "y" if the word below is not dim and has' - & ' black background.'. - 03 LINE + 1, LOWLIGHT BACKGROUND-COLOR 3. - 05 HIGHLIGHT BACKGROUND-COLOR 0. - 07 VALUE 'Highlight'. - 03 LINE + 2, PIC X USING success-flag. - - PROCEDURE DIVISION. - DISPLAY scr - ACCEPT scr - - IF success AND COB-CRT-STATUS = 0 - GOBACK RETURNING 0 - ELSE - GOBACK RETURNING 1 - END-IF - . -]) - -AT_CHECK([$COMPILE prog.cob], [0], [], []) -MANUAL_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) - -AT_CLEANUP - - -AT_SETUP([AUTO]) -AT_KEYWORDS([position]) - -AT_SKIP_IF([test "$COB_HAS_CURSES" != "yes"]) - -AT_DATA([prog.cob], [ - IDENTIFICATION DIVISION. - PROGRAM-ID. prog. - DATA DIVISION. - WORKING-STORAGE SECTION. - 01 dummy PIC X(5). - 01 success-flag PIC X. - 88 success VALUE 'Y', 'y'. - - SCREEN SECTION. - 01 scr. - 03 PIC X(80) VALUE 'Enter "y" in the bottom' - & ' field if:'. - 03 LINE + 1, PIC X(80) VALUE ' * when the left field is' - & ' full, the cursor automatically moves'. - 03 LINE + 1, PIC X(80) VALUE ' to the next field.'. - 03 LINE + 1, PIC X(80) VALUE ' * this does not happen' - & ' with the other fields.'. - 03 LINE + 1, PIC X(80) VALUE ' * the fields below are' - & ' on one line and separated by a single' - & ' column.'. - - 03 test-fields LINE + 2. - 05 field-1 COL 1, PIC X(5) AUTO TO dummy. - 05 field-2 COL + 2, PIC X(5) TO dummy. - 05 field-3 COL + 2, PIC X(5) TO dummy. - 03 success-field LINE + 2, COLUMN 1; PIC X, REQUIRED - TO success-flag FROM 'Y'. - - PROCEDURE DIVISION. - DISPLAY scr - ACCEPT scr - - IF success AND COB-CRT-STATUS = 0 - GOBACK RETURNING 0 - ELSE - GOBACK RETURNING 1 - END-IF - . -]) - -AT_CHECK([$COMPILE prog.cob], [0], [], []) -MANUAL_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) - -AT_CLEANUP - - -AT_SETUP([SCREEN BACKGROUND- / FOREGROUND-COLOUR]) -AT_KEYWORDS([BACKGROUND-COLOR BACKGROUND-COLOUR FOREGROUND-COLOR -COLOR COLOUR HIGHLIGHT BLINK]) - -AT_SKIP_IF([test "$COB_HAS_CURSES" != "yes"]) - -AT_DATA([prog.cob], [ - IDENTIFICATION DIVISION. - PROGRAM-ID. prog. - DATA DIVISION. - WORKING-STORAGE SECTION. - 01 dummy PIC X(10). - 01 success-flag PIC X. - 88 success VALUE 'Y', 'y'. - - SCREEN SECTION. - 01 scr. - 03 PIC X(80) - VALUE 'Enter "y" if the text below matches the colour ' - & 'of the background/text.'. - 03 LINE + 1, COL 1, PIC X(80) - VALUE 'Note: the black text is on white background/the ' - & 'white background has black text'. - 03 LINE + 1, COL 1, PIC X(80) - VALUE 'to make the text visible.'. - - 03 LINE + 1. - 05 COL 1, PIC X(08) VALUE 'Black' FOREGROUND-COLOR 0 - BACKGROUND-COLOR 7. - 05 COL + 2, PIC X(08) VALUE 'Blue' FOREGROUND-COLOR 1. - 05 COL + 2, PIC X(08) VALUE 'Green' FOREGROUND-COLOR 2. - 05 COL + 2, PIC X(08) VALUE 'Cyan' FOREGROUND-COLOR 3. - 05 COL + 2, PIC X(08) VALUE 'Red' FOREGROUND-COLOR 4. - 05 COL + 2, PIC X(08) VALUE 'Magenta' FOREGROUND-COLOR 5. - 05 COL + 2, PIC X(15) VALUE 'Brown/Yellow' - FOREGROUND-COLOR 6. - 05 COL + 2, PIC X(08) VALUE 'White' FOREGROUND-COLOR 7. - - 03 LINE + 1. - 05 COL 1, PIC X(08) VALUE 'Black' BACKGROUND-COLOR 0 - FOREGROUND-COLOR 7. - 05 COL + 2, PIC X(08) VALUE 'Blue' BACKGROUND-COLOR 1. - 05 COL + 2, PIC X(08) VALUE 'Green' BACKGROUND-COLOR 2. - 05 COL + 2, PIC X(08) VALUE 'Cyan' BACKGROUND-COLOR 3. - 05 COL + 2, PIC X(08) VALUE 'Red' BACKGROUND-COLOR 4. - 05 COL + 2, PIC X(08) VALUE 'Magenta' BACKGROUND-COLOR 5. - 05 COL + 2, PIC X(15) VALUE 'Brown/Yellow' - BACKGROUND-COLOR 6. - 05 COL + 2, PIC X(08) VALUE 'White' BACKGROUND-COLOR 7 - FOREGROUND-COLOR 0. - - 03 LINE + 2. - 03 PIC X(80) - VALUE 'The following is the same as above, ' - & 'with "extended" attributes set;'. - 03 LINE + 1, COL 1, PIC X(80) - VALUE 'this should have the same effect as otherwise ' - & 'highlighted for the first line'. - 03 LINE + 1, COL 1, PIC X(80) - VALUE 'and blinking for the second one.'. - - 03 LINE + 1. - 05 COL 1, PIC X(08) VALUE 'Black' FOREGROUND-COLOR 8 - BACKGROUND-COLOR 0. - 05 COL + 2, PIC X(08) VALUE 'Blue' FOREGROUND-COLOR 9. - 05 COL + 2, PIC X(08) VALUE 'Green' FOREGROUND-COLOR 10. - 05 COL + 2, PIC X(08) VALUE 'Cyan' FOREGROUND-COLOR 11. - 05 COL + 2, PIC X(08) VALUE 'Red' FOREGROUND-COLOR 12. - 05 COL + 2, PIC X(08) VALUE 'Magenta' FOREGROUND-COLOR 13. - 05 COL + 2, PIC X(15) VALUE 'Brown/Yellow' - FOREGROUND-COLOR 14. - 05 COL + 2, PIC X(08) VALUE 'White' FOREGROUND-COLOR 15. - - 03 LINE + 1. - 05 COL 1, PIC X(08) VALUE 'Black' BACKGROUND-COLOR 8 - FOREGROUND-COLOR 15. - 05 COL + 2, PIC X(08) VALUE 'Blue' BACKGROUND-COLOR 9. - 05 COL + 2, PIC X(08) VALUE 'Green' BACKGROUND-COLOR 10. - 05 COL + 2, PIC X(08) VALUE 'Cyan' BACKGROUND-COLOR 11. - 05 COL + 2, PIC X(08) VALUE 'Red' BACKGROUND-COLOR 12. - 05 COL + 2, PIC X(08) VALUE 'Magenta' BACKGROUND-COLOR 13. - 05 COL + 2, PIC X(15) VALUE 'Brown/Yellow' - BACKGROUND-COLOR 14. - 05 COL + 2, PIC X(08) VALUE 'White' BACKGROUND-COLOR 15 - FOREGROUND-COLOR 8. - - 03 success-field LINE + 2, COL 1, PIC X, REQUIRED, - TO success-flag FROM 'Y'. - - PROCEDURE DIVISION. - DISPLAY scr - ACCEPT scr - - IF success AND COB-CRT-STATUS = 0 - GOBACK RETURNING 0 - ELSE - GOBACK RETURNING 1 - END-IF - . -]) - -AT_CHECK([$COMPILE prog.cob], [0], [], []) -MANUAL_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) - -AT_CLEANUP - - -AT_SETUP([SCREEN BACKGROUND- / FOREGROUND-COLOUR via COLOR]) -AT_KEYWORDS([BACKGROUND-COLOR BACKGROUND-COLOUR FOREGROUND-COLOR -COLOR COLOUR REVERSED]) - -# Currently not implemented -AT_XFAIL_IF([true]) - -AT_SKIP_IF([test "$COB_HAS_CURSES" != "yes"]) - -AT_DATA([prog.cob], [ - IDENTIFICATION DIVISION. - PROGRAM-ID. prog. - DATA DIVISION. - WORKING-STORAGE SECTION. - 01 dummy PIC X(10). - 01 success-flag PIC X. - 88 success VALUE 'Y', 'y'. - 77 CBLACK PIC 9(05) VALUE 1. - 77 CBLUE PIC 9(05) VALUE 2. - 77 CGREEN PIC 9(05) VALUE 3. - 77 CCYAN PIC 9(05) VALUE 4. - 77 CRED PIC 9(05) VALUE 5. - 77 CMAGENTA PIC 9(05) VALUE 6. - 77 CYELLOW PIC 9(05) VALUE 7. - 77 CWHITE PIC 9(05) VALUE 8. - - SCREEN SECTION. - 01 scr. - 03 PIC X(80) - VALUE 'Enter "y" if the text below matches the colour ' - & 'of the background/text.'. - 03 LINE + 1, COL 1, PIC X(80) - VALUE 'Note: the black text is on white background/the ' - & 'white background has black text'. - 03 LINE + 1, COL 1, PIC X(80) - VALUE 'to make the text visible.'. - - 03 LINE + 1. - 05 COL 1, PIC X(08) VALUE 'Black' COLOR CBLACK. - 05 COL + 2, PIC X(08) VALUE 'Blue' COLOR CBLUE. - 05 COL + 2, PIC X(08) VALUE 'Green' COLOR CGREEN. - 05 COL + 2, PIC X(08) VALUE 'Cyan' COLOR CCYAN. - 05 COL + 2, PIC X(08) VALUE 'Red' COLOR CRED. - 05 COL + 2, PIC X(08) VALUE 'Magenta' COLOR CMAGENTA. - 05 COL + 2, PIC X(15) VALUE 'Brown/Yellow' - COLOR CYELLOW. - 05 COL + 2, PIC X(08) VALUE 'White' COLOR CWHITE. - - 01 scr2. - 03 LINE 5. - 05 COL 1, PIC X(08) VALUE 'Black' BACKGROUND-COLOR 0 - FOREGROUND-COLOR 7. - 05 COL + 2, PIC X(08) VALUE 'Blue' BACKGROUND-COLOR 1. - 05 COL + 2, PIC X(08) VALUE 'Green' BACKGROUND-COLOR 2. - 05 COL + 2, PIC X(08) VALUE 'Cyan' BACKGROUND-COLOR 3. - 05 COL + 2, PIC X(08) VALUE 'Red' BACKGROUND-COLOR 4. - 05 COL + 2, PIC X(08) VALUE 'Magenta' BACKGROUND-COLOR 5. - 05 COL + 2, PIC X(15) VALUE 'Brown/Yellow' - BACKGROUND-COLOR 6. - 05 COL + 2, PIC X(08) VALUE 'White' BACKGROUND-COLOR 7 - FOREGROUND-COLOR 0. - - 03 success-field LINE + 2, COL 1, PIC X, REQUIRED, - TO success-flag FROM 'Y'. - - PROCEDURE DIVISION. - ADD 256 TO CBLACK - DISPLAY scr - ADD 1024 TO CBLACK, CBLUE, CGREEN, CCYAN, - CRED, CMAGENTA, CYELLOW, CWHITE - DISPLAY scr2 - ACCEPT scr - - IF success AND COB-CRT-STATUS = 0 - GOBACK RETURNING 0 - ELSE - GOBACK RETURNING 1 - END-IF - . -]) - -AT_CHECK([$COMPILE prog.cob], [0], [], []) -MANUAL_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) - -AT_CLEANUP - - -AT_SETUP([field BACKGROUND- / FOREGROUND-COLOUR]) -AT_KEYWORDS([BACKGROUND-COLOR BACKGROUND-COLOUR FOREGROUND-COLOR -COLOR COLOUR HIGHLIGHT BLINK]) - -AT_SKIP_IF([test "$COB_HAS_CURSES" != "yes"]) - -AT_DATA([prog.cob], [ - IDENTIFICATION DIVISION. - PROGRAM-ID. prog. - DATA DIVISION. - WORKING-STORAGE SECTION. - 01 dummy PIC X(10). - 01 success-flag PIC X. - 88 success VALUE 'Y', 'y'. - - SCREEN SECTION. - 01 scr. - 03 PIC X(80) - VALUE 'Enter "y" if the text below matches the colour ' - & 'of the background/text.'. - 03 LINE + 1, COL 1, PIC X(80) - VALUE 'Note: the black text is on white background/the ' - & 'white background has black text'. - 03 LINE + 1, COL 1, PIC X(80) - VALUE 'to make the text visible.'. - - 03 LINE + 1. - 05 COL 1, PIC X(08) VALUE 'Black' FOREGROUND-COLOR 0 - BACKGROUND-COLOR 7. - 05 COL + 2, PIC X(08) VALUE 'Blue' FOREGROUND-COLOR 1. - 05 COL + 2, PIC X(08) VALUE 'Green' FOREGROUND-COLOR 2. - 05 COL + 2, PIC X(08) VALUE 'Cyan' FOREGROUND-COLOR 3. - 05 COL + 2, PIC X(08) VALUE 'Red' FOREGROUND-COLOR 4. - 05 COL + 2, PIC X(08) VALUE 'Magenta' FOREGROUND-COLOR 5. - 05 COL + 2, PIC X(15) VALUE 'Brown/Yellow' - FOREGROUND-COLOR 6. - 05 COL + 2, PIC X(08) VALUE 'White' FOREGROUND-COLOR 7. - - 03 LINE + 1. - 05 COL 1, PIC X(08) VALUE 'Black' BACKGROUND-COLOR 0 - FOREGROUND-COLOR 7. - 05 COL + 2, PIC X(08) VALUE 'Blue' BACKGROUND-COLOR 1. - 05 COL + 2, PIC X(08) VALUE 'Green' BACKGROUND-COLOR 2. - 05 COL + 2, PIC X(08) VALUE 'Cyan' BACKGROUND-COLOR 3. - 05 COL + 2, PIC X(08) VALUE 'Red' BACKGROUND-COLOR 4. - 05 COL + 2, PIC X(08) VALUE 'Magenta' BACKGROUND-COLOR 5. - 05 COL + 2, PIC X(15) VALUE 'Brown/Yellow' - BACKGROUND-COLOR 6. - 05 COL + 2, PIC X(08) VALUE 'White' BACKGROUND-COLOR 7 - FOREGROUND-COLOR 0. - - 03 LINE + 2. - 03 PIC X(80) - VALUE 'The following is the same as above, ' - & 'with "extended" attributes set;'. - 03 LINE + 1, COL 1, PIC X(80) - VALUE 'this should have the same effect as otherwise ' - & 'highlighted for the first line'. - 03 LINE + 1, COL 1, PIC X(80) - VALUE 'and blinking for the second one.'. - - 03 LINE + 1. - 05 COL 1, PIC X(08) VALUE 'Black' FOREGROUND-COLOR 8 - BACKGROUND-COLOR 0. - 05 COL + 2, PIC X(08) VALUE 'Blue' FOREGROUND-COLOR 9. - 05 COL + 2, PIC X(08) VALUE 'Green' FOREGROUND-COLOR 10. - 05 COL + 2, PIC X(08) VALUE 'Cyan' FOREGROUND-COLOR 11. - 05 COL + 2, PIC X(08) VALUE 'Red' FOREGROUND-COLOR 12. - 05 COL + 2, PIC X(08) VALUE 'Magenta' FOREGROUND-COLOR 13. - 05 COL + 2, PIC X(15) VALUE 'Brown/Yellow' - FOREGROUND-COLOR 14. - 05 COL + 2, PIC X(08) VALUE 'White' FOREGROUND-COLOR 15. - - 03 LINE + 1. - 05 COL 1, PIC X(08) VALUE 'Black' BACKGROUND-COLOR 8 - FOREGROUND-COLOR 15. - 05 COL + 2, PIC X(08) VALUE 'Blue' BACKGROUND-COLOR 9. - 05 COL + 2, PIC X(08) VALUE 'Green' BACKGROUND-COLOR 10. - 05 COL + 2, PIC X(08) VALUE 'Cyan' BACKGROUND-COLOR 11. - 05 COL + 2, PIC X(08) VALUE 'Red' BACKGROUND-COLOR 12. - 05 COL + 2, PIC X(08) VALUE 'Magenta' BACKGROUND-COLOR 13. - 05 COL + 2, PIC X(15) VALUE 'Brown/Yellow' - BACKGROUND-COLOR 14. - 05 COL + 2, PIC X(08) VALUE 'White' BACKGROUND-COLOR 15 - FOREGROUND-COLOR 8. - - 03 success-field LINE + 2, COL 1, PIC X, REQUIRED, - TO success-flag FROM 'Y'. - - PROCEDURE DIVISION. - DISPLAY scr - ACCEPT scr - - IF success AND COB-CRT-STATUS = 0 - GOBACK RETURNING 0 - ELSE - GOBACK RETURNING 1 - END-IF - . -]) - -AT_CHECK([$COMPILE prog.cob], [0], [], []) -MANUAL_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) - -AT_CLEANUP - - -AT_SETUP([field BACKGROUND- / FOREGROUND-COLOUR via COLOR]) -AT_KEYWORDS([BACKGROUND-COLOR BACKGROUND-COLOUR FOREGROUND-COLOR -COLOR COLOUR REVERSED HIGHLIGHT BLINK]) - -AT_SKIP_IF([test "$COB_HAS_CURSES" != "yes"]) - -AT_DATA([prog.cob], [ - IDENTIFICATION DIVISION. - PROGRAM-ID. prog. - DATA DIVISION. - WORKING-STORAGE SECTION. - 01 success-flag PIC X VALUE 'Y'. - 88 success VALUE 'Y', 'y'. - - 77 CBLACK PIC 9(05) COMP-5 VALUE 1. - 77 CBLUE PIC 9(05) COMP-5 VALUE 2. - 77 CGREEN PIC 9(05) COMP-5 VALUE 3. - 77 CCYAN PIC 9(05) COMP-5 VALUE 4. - 77 CRED PIC 9(05) COMP-5 VALUE 5. - 77 CMAGENTA PIC 9(05) COMP-5 VALUE 6. - 77 CYELLOW PIC 9(05) COMP-5 VALUE 7. - 77 CWHITE PIC 9(05) COMP-5 VALUE 8. - - 77 LIN PIC 99 COMP-5. - - 01 scr1 PIC X(80) - VALUE 'Enter "y" if the text below matches the colour ' - & 'of the background/text.'. - 01 scr2 PIC X(80) - VALUE 'Note: the black text is on white background/the ' - & 'white background has black text'. - 01 scr3 PIC X(80) - VALUE 'to make the text visible.'. - 01 scr8 PIC X(80) - VALUE 'following lines should be identical but ' - & 'highlighted for the first line'. - 01 scr9 PIC X(80) - VALUE 'and blinking for the second one.'. - - 01 scrblack PIC X(08) VALUE 'Black'. - 01 scrblue PIC X(08) VALUE 'Blue'. - 01 scrgreen PIC X(08) VALUE 'Green'. - 01 scrcyan PIC X(08) VALUE 'Cyan'. - 01 scrred PIC X(08) VALUE 'Red'. - 01 scrmaggy PIC X(08) VALUE 'Magenta'. - 01 scryell PIC X(14) VALUE 'Brown/Yellow'. - 01 scrwhite PIC X(08) VALUE 'White'. - - PROCEDURE DIVISION. - testme. - ADD 256 TO CBLACK - DISPLAY scr1 AT 0102 - DISPLAY scr2 AT 0202 - DISPLAY scr3 AT 0303 - MOVE 5 TO LIN - PERFORM dspcol - ADD 1024 TO CBLACK, CBLUE, CGREEN, CCYAN, - CRED, CMAGENTA, CYELLOW, CWHITE - MOVE 6 TO LIN - PERFORM dspcol - SUBTRACT 1024 FROM CBLACK, CBLUE, CGREEN, CCYAN, - CRED, CMAGENTA, CYELLOW, CWHITE - * - DISPLAY scr8 AT 0802 - DISPLAY scr9 AT 0903 - ADD 4096 TO CBLACK, CBLUE, CGREEN, CCYAN, - CRED, CMAGENTA, CYELLOW, CWHITE - MOVE 11 TO LIN - PERFORM dspcol - SUBTRACT 4096 FROM CBLACK, CBLUE, CGREEN, CCYAN, - CRED, CMAGENTA, CYELLOW, CWHITE - ADD 1024, 16384 TO CBLACK, CBLUE, CGREEN, CCYAN, - CRED, CMAGENTA, CYELLOW, CWHITE - MOVE 12 TO LIN - PERFORM dspcol - * - ACCEPT success-flag AT 1401 UPDATE REQUIRED - - IF success AND COB-CRT-STATUS = 0 - GOBACK RETURNING 0 - ELSE - GOBACK RETURNING 1. - - dspcol. - DISPLAY scrblack LINE LIN COL 1, COLOR CBLACK. - DISPLAY scrblue LINE LIN COL 11, COLOR CBLUE. - DISPLAY scrgreen LINE LIN COL 21, COLOR CGREEN. - DISPLAY scrcyan LINE LIN COL 31, COLOR CCYAN. - DISPLAY scrred LINE LIN COL 41, COLOR CRED. - DISPLAY scrmaggy LINE LIN COL 51, COLOR CMAGENTA. - DISPLAY scryell LINE LIN COL 61, COLOR CYELLOW. - DISPLAY scrwhite LINE LIN COL 77, COLOR CWHITE. -]) - -AT_CHECK([$COMPILE prog.cob], [0], [], []) -MANUAL_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) - -AT_CLEANUP - - -AT_SETUP([field BACKGROUND- / FOREGROUND-COLOUR via CONTROL]) -AT_KEYWORDS([screen DISPLAY REVERSED HIGHLIGHT BLINK COLOR -BACKGROUND-COLOR BACKGROUND-COLOUR FOREGROUND-COLOR COLOUR]) - -AT_SKIP_IF([test "$COB_HAS_CURSES" != "yes"]) - -AT_DATA([prog.cob], [[ - IDENTIFICATION DIVISION. - PROGRAM-ID. prog. - DATA DIVISION. - WORKING-STORAGE SECTION. - 01 success-flag PIC X VALUE 'Y'. - 88 success VALUE 'Y', 'y'. - - * ACU: "=", names only - 77 CBLACK PIC X(99) VALUE "FCOLOR=BLACK, " - & "BCOLOR=WHITE,". - 77 CBLUE PIC X(99) VALUE "FCOLOR=BLUE , " - & "BCOLOR=BLACK,". - * MF: "IS" or "=" or " ", also extended color numbers - 77 CGREEN PIC X(99) VALUE "FCOLOR IS GREEN, " - & "BCOLOR BLACK,". - 77 CCYAN PIC X(99) VALUE "FCOLOR =CYAN, " - & "BCOLOR= BLACK, ". - 77 CRED PIC X(99) VALUE "FCOLOR=RED " - & "BCOLOR=BLACK, ". - 77 CMAGENTA PIC X(99) VALUE "FCOLOR=MAGENTA, " - & "BCOLOR=BLACK,". - 77 CYELLOW PIC X(99) VALUE "FCOLOR = 6, " - & "BCOLOR=BLACK,". - 77 CWHITE PIC X(99) VALUE "FCOLOR=WHITE, " - & "BCOLOR=BLACK, ". - - 77 LIN PIC 99 COMP-5. - - 01 scr1 PIC X(75) - VALUE 'Enter "y" if the text below matches the colour ' - & 'of the background/text.'. - 01 scr2 PIC X(75) - VALUE 'Note: the black text is on white background/the ' - & 'white background has black'. - 01 scr3 PIC X(75) - VALUE 'text to make the text visible.' - & ' [This text *may* has "surrounding lines".]'. - 01 scr8 PIC X(75) - VALUE 'following lines should be identical but ' - & 'highlighted for the first line'. - 01 scr9 PIC X(75) - VALUE 'and blinking for the second one.'. - - 01 scrblack PIC X(08) VALUE 'Black'. - 01 scrblue PIC X(08) VALUE 'Blue'. - 01 scrgreen PIC X(08) VALUE 'Green'. - 01 scrcyan PIC X(08) VALUE 'Cyan'. - 01 scrred PIC X(08) VALUE 'Red'. - 01 scrmaggy PIC X(08) VALUE 'Magenta'. - 01 scryell PIC X(14) VALUE 'Brown/Yellow'. - 01 scrwhite PIC X(08) VALUE 'White'. - - PROCEDURE DIVISION. - testme. - MOVE 2 TO LIN - DISPLAY scr1 ( 1:1) AT LINE LIN COL 2 - CONTROL "LEFTLINE OVERLINE" - DISPLAY scr1 ( 2:) AT LINE LIN COL 2 + 1 - CONTROL "OVERLINE" - DISPLAY scr1 (75:) AT LINE LIN COL 2 + 75 - CONTROL "OVERLINE RIGHTLINE" - ADD 1 TO LIN - DISPLAY scr2 ( 1:1) AT LINE LIN COL 2 - CONTROL "LEFTLINE" - DISPLAY scr2 ( 2:) AT LINE LIN COL 2 + 1 - DISPLAY scr2 (75:) AT LINE LIN COL 2 + 75 - CONTROL "RIGHTLINE" - ADD 1 TO LIN - DISPLAY scr3 ( 1:1) AT LINE LIN COL 2 - CONTROL "LEFTLINE UNDERLINE" - DISPLAY scr3 ( 2:) AT LINE LIN COL 2 + 1 - CONTROL "UNDERLINE" - DISPLAY scr3 (75:) AT LINE LIN COL 2 + 75 - CONTROL "UNDERLINE RIGHTLINE" - * - ADD 2 TO LIN - PERFORM dspcol - MOVE "REVERSE," TO - CBLACK (40:), CBLUE (40:), CGREEN (40:), CCYAN (40:), - CRED (40:), CMAGENTA (40:), CYELLOW (40:), CWHITE (40:) - ADD 1 TO LIN - PERFORM dspcol - * - INSPECT CRED REPLACING ALL "=" BY " " - ADD 2 TO LIN - DISPLAY scr8 AT LINE LIN COL 2 - ADD 1 TO LIN - DISPLAY scr9 AT LINE LIN COL 2 - * - MOVE "HIGHLIGHT,NO REVERSE" TO - CBLACK (50:), CBLUE (50:), CGREEN (50:), CCYAN (50:), - CRED (50:), CMAGENTA (50:), CYELLOW (50:), CWHITE (50:) - ADD 1 TO LIN - PERFORM dspcol - MOVE "NO HIGH, BLINK" TO - CBLACK (60:), CBLUE (60:), CGREEN (60:), CCYAN (60:), - CRED (60:), CMAGENTA (60:), CYELLOW (60:), CWHITE (60:) - MOVE 12 TO LIN - PERFORM dspcol - * - ACCEPT success-flag AT 1801 UPDATE REQUIRED - - IF success AND COB-CRT-STATUS = 0 - GOBACK RETURNING 0 - ELSE - GOBACK RETURNING 1. - - dspcol. - DISPLAY scrblack LINE LIN COL 1, CONTROL CBLACK. - DISPLAY scrblue LINE LIN COL 10, CONTROL CBLUE. - DISPLAY scrgreen LINE LIN COL 19, CONTROL CGREEN. - DISPLAY scrcyan LINE LIN COL 28, CONTROL CCYAN. - DISPLAY scrred LINE LIN COL 37, CONTROL CRED. - DISPLAY scrmaggy LINE LIN COL 46, CONTROL CMAGENTA. - DISPLAY scryell LINE LIN COL 55, CONTROL CYELLOW. - DISPLAY scrwhite LINE LIN COL 70, CONTROL CWHITE. -]]) - -AT_CHECK([$COMPILE prog.cob], [0], [], []) -MANUAL_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) - -AT_CLEANUP - - -AT_SETUP([line draw characters via CONTROL GRAPHICS]) -AT_KEYWORDS([screen DISPLAY]) - -AT_SKIP_IF([test "$COB_HAS_CURSES" != "yes"]) - -AT_DATA([prog.cob], [[ - IDENTIFICATION DIVISION. - PROGRAM-ID. prog. - DATA DIVISION. - WORKING-STORAGE SECTION. - 01 success-flag PIC X VALUE 'Y'. - 88 success VALUE 'Y', 'y'. - - 77 LIN-START PIC 99 COMP-5. - 77 LIN PIC 99 COMP-5. - - 01 scr1 PIC X(75) - VALUE 'Enter "y" if you see line draw characters. ' - & 'The first set (single/double)'. - 01 scr2 PIC X(75) - VALUE 'uses HIGHLIGHT, the second uses ' - & 'LOWLIGHT, BLINK and MAGENTA.'. - - 01 graphcontrol PIC X(50) VALUE 'HIGH, GRAPHICS'. - - PROCEDURE DIVISION. - testme. - MOVE 2 TO LIN - DISPLAY scr1 AT LINE LIN COL 2 - ADD 1 TO LIN - DISPLAY scr2 AT LINE LIN COL 2 - * - MOVE 5 TO LIN-START - PERFORM dspcol - MOVE 12 TO LIN-START - MOVE "LOW BLINK FCOLOR=MAGENTA GRAPHICS" TO graphcontrol - PERFORM dspcol - * - ACCEPT success-flag AT 1801 UPDATE REQUIRED - - IF success AND COB-CRT-STATUS = 0 - GOBACK RETURNING 0 - ELSE - GOBACK RETURNING 1. - - dspcol. - * Single-line graphics - MOVE LIN-START TO LIN - DISPLAY "lqqqqwqqqqk" LINE LIN COL 05, CONTROL graphcontrol. - ADD 1 TO LIN - DISPLAY "x x x" LINE LIN COL 05, CONTROL graphcontrol. - ADD 1 TO LIN - DISPLAY "tqqqqnqqqqu" LINE LIN COL 05, CONTROL graphcontrol. - ADD 1 TO LIN - DISPLAY "x x x" LINE LIN COL 05, CONTROL graphcontrol. - ADD 1 TO LIN - DISPLAY "mqqqqvqqqqj" LINE LIN COL 05, CONTROL graphcontrol. - ADD 1 TO LIN - * Double-line graphics - MOVE LIN-START TO LIN - DISPLAY "LQQQQWQQQQK" LINE LIN COL 20, CONTROL graphcontrol. - ADD 1 TO LIN - DISPLAY "X X X" LINE LIN COL 20, CONTROL graphcontrol. - ADD 1 TO LIN - DISPLAY "TQQQQNQQQQU" LINE LIN COL 20, CONTROL graphcontrol. - ADD 1 TO LIN - DISPLAY "X X X" LINE LIN COL 20, CONTROL graphcontrol. - ADD 1 TO LIN - DISPLAY "MQQQQVQQQQJ" LINE LIN COL 20, CONTROL graphcontrol. -]]) - -AT_CHECK([$COMPILE prog.cob], [0], [], []) -MANUAL_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) - -AT_CLEANUP - - -AT_SETUP([BEEP]) -AT_KEYWORDS([BELL FLASH]) - -AT_SKIP_IF([test "$COB_HAS_CURSES" != "yes"]) - -AT_DATA([prog.cob], [ - IDENTIFICATION DIVISION. - PROGRAM-ID. prog. - DATA DIVISION. - WORKING-STORAGE SECTION. - 01 success-flag PIC X. - 88 success VALUE 'Y', 'y'. - - SCREEN SECTION. - 01 scr. - 03 BELL. - 03 VALUE 'Enter "y" if you heard a beep:'. - 03 success-field PIC X, COL + 2, REQUIRED, TO success-flag - FROM 'Y'. - 01 scr2. - 03 LINE 4 VALUE 'system beep may be turned off ' & - 'on this system.'. - 03 LINE 5 VALUE 'Retesting with COB_BELL=FLASH...'. - 03 LINE + 2, - VALUE 'Enter "y" if you''ve seen your terminal flash'. - 03 success-field PIC X, COL + 2, REQUIRED, TO success-flag - FROM 'Y'. - - PROCEDURE DIVISION. - DISPLAY scr - ACCEPT scr - - IF success AND COB-CRT-STATUS = 0 - GOBACK RETURNING 0 - END-IF - - SET ENVIRONMENT 'COB_BELL' TO 'FLASH' - CALL 'C$SLEEP' USING '1' - - DISPLAY scr2 - DISPLAY ALL X'07' UPON CRT - ACCEPT scr2 - - IF success AND COB-CRT-STATUS = 0 - GOBACK RETURNING 0 - ELSE - GOBACK RETURNING 1 - END-IF - . -]) - -AT_CHECK([$COMPILE prog.cob], [0], [], []) -MANUAL_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) - -AT_CLEANUP - - -AT_SETUP([BLANK LINE]) -AT_KEYWORDS([screen]) - -AT_SKIP_IF([test "$COB_HAS_CURSES" != "yes"]) - -AT_DATA([prog.cob], [ - IDENTIFICATION DIVISION. - PROGRAM-ID. prog. - - DATA DIVISION. - WORKING-STORAGE SECTION. - 01 success-flag PIC X VALUE 'Y'. - 88 success VALUE 'Y', 'y'. - - SCREEN SECTION. - 01 scr-1. - 03 LINE 3 VALUE 'Lorem ipsum dolor sit amet, consectetur ad' - & 'ipiscing elit. Curabitur dapibus dui'. - 03 LINE 4 VALUE 'vitae augue lobortis, non tempor diam tris' - & 'tique. Donec dignissim ex velit, ut'. - 03 LINE 5 VALUE 'efficitur tellus pharetra at. Curabitur at' - & ' condimentum nunc, nec accumsan'. - 03 LINE 6 VALUE 'nulla. Nulla at feugiat elit, eget condime' - & 'ntum justo. Nam lorem lectus,'. - 03 LINE 7 VALUE 'imperdiet sit amet odio eu, eleifend conse' - & 'ctetur ligula. Duis diam felis, porta'. - 03 LINE 8 VALUE 'id diam id, ultrices finibus augue. Mauris' - & ' imperdiet, dolor sed sodales porta,'. - 03 LINE 9 VALUE 'justo nunc consequat nulla, iaculis venena' - & 'tis lorem libero sit amet'. - 03 LINE 10 VALUE 'magna. Nullam pulvinar nullam.'. - 03 success-field LINE + 2, PIC X, REQUIRED, - USING success-flag. - - 01 scr-2. - 03 LINE 6 COL 8 VALUE 'foo' BLANK LINE, HIGHLIGHT. - 03 LINE 1 VALUE 'Enter "y" if foo is the only word on one' - & ' line.'. - - PROCEDURE DIVISION. - DISPLAY scr-1 - DISPLAY scr-2 - ACCEPT success-field - - IF success AND COB-CRT-STATUS = 0 - GOBACK RETURNING 0 - ELSE - GOBACK RETURNING 1 - END-IF - . -]) - -AT_CHECK([$COMPILE prog.cob], [0], [], []) -MANUAL_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) - -AT_CLEANUP - - -AT_SETUP([BLANK SCREEN]) -AT_KEYWORDS([screen]) - -AT_SKIP_IF([test "$COB_HAS_CURSES" != "yes"]) - -AT_DATA([prog.cob], [ - IDENTIFICATION DIVISION. - PROGRAM-ID. prog. - - DATA DIVISION. - WORKING-STORAGE SECTION. - 01 success-flag PIC X VALUE 'Y'. - 88 success VALUE 'Y', 'y'. - - SCREEN SECTION. - 01 scr-1. - 03 LINE 3 VALUE 'Lorem ipsum dolor sit amet, consectetur ad' - & 'ipiscing elit. Curabitur dapibus dui'. - 03 LINE 4 VALUE 'vitae augue lobortis, non tempor diam tris' - & 'tique. Donec dignissim ex velit, ut'. - 03 LINE 5 VALUE 'efficitur tellus pharetra at. Curabitur at' - & ' condimentum nunc, nec accumsan'. - 03 LINE 6 VALUE 'nulla. Nulla at feugiat elit, eget condime' - & 'ntum justo. Nam lorem lectus,'. - 03 LINE 7 VALUE 'imperdiet sit amet odio eu, eleifend conse' - & 'ctetur ligula. Duis diam felis, porta'. - 03 LINE 8 VALUE 'id diam id, ultrices finibus augue. Mauris' - & ' imperdiet, dolor sed sodales porta,'. - 03 LINE 9 VALUE 'justo nunc consequat nulla, iaculis venena' - & 'tis lorem libero sit amet'. - 03 LINE 10 VALUE 'magna. Nullam pulvinar nullam.'. - 03 success-field LINE + 2, PIC X, REQUIRED, - USING success-flag. - - 01 scr-2. - 03 LINE 6 COL 8 VALUE 'foo' BLANK SCREEN, HIGHLIGHT. - 03 LINE 1 VALUE 'Enter "y" if foo is the only word below.'. - - PROCEDURE DIVISION. - DISPLAY scr-1 - DISPLAY scr-2 - ACCEPT success-field - - IF success AND COB-CRT-STATUS = 0 - GOBACK RETURNING 0 - ELSE - GOBACK RETURNING 1 - END-IF - . -]) - -AT_CHECK([$COMPILE prog.cob], [0], [], []) -MANUAL_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) - -AT_CLEANUP - - -AT_SETUP([BLANK ignored in ACCEPT]) -AT_KEYWORDS([screen]) - -AT_SKIP_IF([test "$COB_HAS_CURSES" != "yes"]) - -AT_DATA([prog.cob], [ - IDENTIFICATION DIVISION. - PROGRAM-ID. prog. - - DATA DIVISION. - WORKING-STORAGE SECTION. - 01 success-flag PIC X VALUE 'Y'. - 88 success VALUE 'Y', 'y'. - - SCREEN SECTION. - 01 scr. - 03 LINE 1 VALUE 'Enter "y" if you can see lorem ipsum ' - & 'filler text.'. - 03 LINE 3 COL 3 VALUE 'Lorem ipsum dolor sit amet,' - & ' consectetur ad ipiscing elit.'. - - 01 success-scr. - 03 LINE 3, BLANK LINE, PIC X, REQUIRED, USING success-flag. - - PROCEDURE DIVISION. - DISPLAY scr - ACCEPT success-scr - - IF success AND COB-CRT-STATUS = 0 - GOBACK RETURNING 0 - ELSE - GOBACK RETURNING 1 - END-IF - . -]) - -AT_CHECK([$COMPILE prog.cob], [0], [], []) -MANUAL_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) - -AT_CLEANUP - - -AT_SETUP([BLINK]) -AT_KEYWORDS([screen]) - -AT_SKIP_IF([test "$COB_HAS_CURSES" != "yes"]) - -AT_DATA([prog.cob], [ - IDENTIFICATION DIVISION. - PROGRAM-ID. prog. - DATA DIVISION. - WORKING-STORAGE SECTION. - 01 success-flag PIC X VALUE 'Y'. - 88 success VALUE 'Y', 'y'. - - SCREEN SECTION. - 01 scr. - 03 PIC X(80) - VALUE 'Enter "y" if the string below is blinking:'. - 03 LINE + 1, PIC X(10) VALUE 'Blink' BLINK. - 03 success-field LINE + 2, PIC X, REQUIRED, - USING success-flag. - - PROCEDURE DIVISION. - DISPLAY scr - ACCEPT scr - - IF success AND COB-CRT-STATUS = 0 - GOBACK RETURNING 0 - ELSE - GOBACK RETURNING 1 - END-IF - . -]) - -AT_CHECK([$COMPILE prog.cob], [0], [], []) -MANUAL_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) - -AT_CLEANUP - - -AT_SETUP([ERASE EOS]) -AT_KEYWORDS([screen]) - -AT_SKIP_IF([test "$COB_HAS_CURSES" != "yes"]) - -AT_DATA([prog.cob], [ - IDENTIFICATION DIVISION. - PROGRAM-ID. prog. - - DATA DIVISION. - WORKING-STORAGE SECTION. - 01 success-flag PIC X VALUE 'Y'. - 88 success VALUE 'Y', 'y'. - - SCREEN SECTION. - 01 scr-1. - 03 LINE 1 VALUE 'Enter "y" if all the text after foo in the' - & ' screen has been erased.'. - 03 LINE 3 VALUE 'Lorem ipsum dolor sit amet, consectetur ad' - & 'ipiscing elit. Curabitur dapibus dui'. - 03 LINE 4 VALUE 'vitae augue lobortis, non tempor diam tris' - & 'tique. Donec dignissim ex velit, ut'. - 03 LINE 5 VALUE 'efficitur tellus pharetra at. Curabitur at' - & ' condimentum nunc, nec accumsan'. - 03 LINE 6 VALUE 'nulla. Nulla at feugiat elit, eget condime' - & 'ntum justo. Nam lorem lectus,'. - 03 LINE 7 VALUE 'imperdiet sit amet odio eu, eleifend conse' - & 'ctetur ligula. Duis diam felis, porta'. - 03 LINE 8 VALUE 'id diam id, ultrices finibus augue. Mauris' - & ' imperdiet, dolor sed sodales porta,'. - 03 LINE 9 VALUE 'justo nunc consequat nulla, iaculis venena' - & 'tis lorem libero sit amet'. - 03 LINE 10 VALUE 'magna. Nullam pulvinar nullam.'. - 03 success-field LINE + 2, PIC X, REQUIRED, - USING success-flag. - - 01 scr-2. - 03 LINE 6 COL 8 VALUE 'foo' ERASE EOS, HIGHLIGHT. - - PROCEDURE DIVISION. - DISPLAY scr-1 - DISPLAY scr-2 - ACCEPT success-field - - IF success AND COB-CRT-STATUS = 0 - GOBACK RETURNING 0 - ELSE - GOBACK RETURNING 1 - END-IF - . -]) - -AT_CHECK([$COMPILE prog.cob], [0], [], []) -MANUAL_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) - -AT_CLEANUP - - -AT_SETUP([ERASE EOL]) -AT_KEYWORDS([screen]) - -AT_SKIP_IF([test "$COB_HAS_CURSES" != "yes"]) - -AT_DATA([prog.cob], [ - IDENTIFICATION DIVISION. - PROGRAM-ID. prog. - - DATA DIVISION. - WORKING-STORAGE SECTION. - 01 success-flag PIC X VALUE 'Y'. - 88 success VALUE 'Y', 'y'. - - SCREEN SECTION. - 01 scr-1. - 03 LINE 1 VALUE 'Enter "y" if all the text after foo on ' - & 'that line alone has been erased.'. - 03 LINE 3 VALUE 'Lorem ipsum dolor sit amet, consectetur ad' - & 'ipiscing elit. Curabitur dapibus dui'. - 03 LINE 4 VALUE 'vitae augue lobortis, non tempor diam tris' - & 'tique. Donec dignissim ex velit, ut'. - 03 LINE 5 VALUE 'efficitur tellus pharetra at. Curabitur at' - & ' condimentum nunc, nec accumsan'. - 03 LINE 6 VALUE 'nulla. Nulla at feugiat elit, eget condime' - & 'ntum justo. Nam lorem lectus,'. - 03 LINE 7 VALUE 'imperdiet sit amet odio eu, eleifend conse' - & 'ctetur ligula. Duis diam felis, porta'. - 03 LINE 8 VALUE 'id diam id, ultrices finibus augue. Mauris' - & ' imperdiet, dolor sed sodales porta,'. - 03 LINE 9 VALUE 'justo nunc consequat nulla, iaculis venena' - & 'tis lorem libero sit amet'. - 03 LINE 10 VALUE 'magna. Nullam pulvinar nullam.'. - 03 success-field LINE + 2, PIC X, REQUIRED, - USING success-flag. - - 01 scr-2. - 03 LINE 6 COL 8 VALUE 'foo' ERASE EOL, HIGHLIGHT. - - PROCEDURE DIVISION. - DISPLAY scr-1 - DISPLAY scr-2 - ACCEPT success-field - - IF success AND COB-CRT-STATUS = 0 - GOBACK RETURNING 0 - ELSE - GOBACK RETURNING 1 - END-IF - . -]) - -AT_CHECK([$COMPILE prog.cob], [0], [], []) -MANUAL_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) - -AT_CLEANUP - - -AT_SETUP([ERASE ignored in ACCEPT]) -AT_KEYWORDS([EOS]) - -AT_SKIP_IF([test "$COB_HAS_CURSES" != "yes"]) - -AT_DATA([prog.cob], [ - IDENTIFICATION DIVISION. - PROGRAM-ID. prog. - - DATA DIVISION. - WORKING-STORAGE SECTION. - 01 success-flag PIC X VALUE 'Y'. - 88 success VALUE 'Y', 'y'. - - SCREEN SECTION. - 01 scr. - 03 LINE 1 VALUE 'Enter "y" if you can see lorem ipsum ' - & 'filler text.'. - 03 LINE 3 VALUE 'Lorem ipsum dolor sit amet, consectetur ad' - & 'ipiscing elit. Curabitur dapibus dui'. - 03 LINE 4 VALUE 'vitae augue lobortis, non tempor diam tris' - & 'tique. Donec dignissim ex velit, ut'. - 03 LINE 5 VALUE 'efficitur tellus pharetra at. Curabitur at' - & ' condimentum nunc, nec accumsan'. - 03 LINE 6 VALUE 'nulla. Nulla at feugiat elit, eget condime' - & 'ntum justo. Nam lorem lectus,'. - 03 LINE 7 VALUE 'imperdiet sit amet odio eu, eleifend conse' - & 'ctetur ligula. Duis diam felis, porta'. - 03 LINE 8 VALUE 'id diam id, ultrices finibus augue. Mauris' - & ' imperdiet, dolor sed sodales porta,'. - 03 LINE 9 VALUE 'justo nunc consequat nulla, iaculis venena' - & 'tis lorem libero sit amet'. - 03 LINE 10 VALUE 'magna. Nullam pulvinar nullam.'. - 03 LINE 3 ERASE EOS. - 03 success-field LINE 12, PIC X, REQUIRED, - USING success-flag. - - PROCEDURE DIVISION. - DISPLAY scr - ACCEPT scr - - IF success AND COB-CRT-STATUS = 0 - GOBACK RETURNING 0 - ELSE - GOBACK RETURNING 1 - END-IF - . -]) - -AT_CHECK([$COMPILE prog.cob], [0], [], []) -MANUAL_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) - -AT_CLEANUP - - -AT_SETUP([FULL and REQUIRED]) -AT_KEYWORDS([screen]) - -AT_SKIP_IF([test "$COB_HAS_CURSES" != "yes"]) - -AT_DATA([prog.cob], [ - IDENTIFICATION DIVISION. - PROGRAM-ID. prog. - DATA DIVISION. - WORKING-STORAGE SECTION. - 01 dummy PIC X(10). - 01 success-flag PIC X. - 88 success VALUE 'Y', 'y'. - - SCREEN SECTION. - 01 scr. - 03 PIC X(80) - VALUE 'Enter "y" if you cannot continue without filling ' - & 'all of the below field:'. - 03 LINE + 1, PIC X(10), FULL, REQUIRED, TO dummy. - *> no initial value for success as we request input - 03 success-field LINE + 2, PIC X, REQUIRED, TO success-flag. - - PROCEDURE DIVISION. - DISPLAY scr - ACCEPT scr - - IF success AND COB-CRT-STATUS = 0 - GOBACK RETURNING 0 - ELSE - GOBACK RETURNING 1 - END-IF - . -]) - -AT_CHECK([$COMPILE prog.cob], [0], [], []) -MANUAL_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) - -AT_CLEANUP - - -AT_SETUP([HIGHLIGHT]) -AT_KEYWORDS([screen]) - -AT_SKIP_IF([test "$COB_HAS_CURSES" != "yes"]) - -AT_DATA([prog.cob], [ - IDENTIFICATION DIVISION. - PROGRAM-ID. prog. - DATA DIVISION. - WORKING-STORAGE SECTION. - 01 success-flag PIC X VALUE 'Y'. - 88 success VALUE 'Y', 'y'. - - SCREEN SECTION. - 01 scr. - 03 PIC X(80) - VALUE 'Enter "y" if the text below is bright ' - & '(highlighted):'. - 03 LINE + 1, PIC X(10) VALUE 'Highlight' HIGHLIGHT. - 03 success-field LINE + 2, PIC X, REQUIRED, - USING success-flag. - - PROCEDURE DIVISION. - DISPLAY scr - ACCEPT scr - - IF success AND COB-CRT-STATUS = 0 - GOBACK RETURNING 0 - ELSE - GOBACK RETURNING 1 - END-IF - . -]) - -AT_CHECK([$COMPILE prog.cob], [0], [], []) -MANUAL_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) - -AT_CLEANUP - - -AT_SETUP([INITIAL]) -AT_KEYWORDS([screen]) - -AT_SKIP_IF([test "$COB_HAS_CURSES" != "yes"]) - -AT_DATA([prog.cob], [ - IDENTIFICATION DIVISION. - PROGRAM-ID. prog. - - DATA DIVISION. - WORKING-STORAGE SECTION. - 01 dummy-1 PIC X(10). - 01 dummy-2 PIC X(10). - 01 dummy-3 PIC X(10). - - 01 success-flag PIC X VALUE 'Y'. - 88 success VALUE 'Y', 'y'. - - SCREEN SECTION. - 01 scr. - 03 PIC X(80) VALUE 'Enter "y" if the cursor is initially '- - 'located at the start of the rightmost'. - 03 LINE + 1, PIC X(80) VALUE 'field.'. - 03 LINE + 2, PIC X(10) TO dummy-1. - 03 COL + 2, PIC X(10) TO dummy-2. - 03 COL + 2, PIC X(10) TO dummy-3, INITIAL. - 03 success-field LINE + 2, PIC X, REQUIRED, - USING success-flag. - - PROCEDURE DIVISION. - DISPLAY scr - ACCEPT scr - - IF success AND COB-CRT-STATUS = 0 - GOBACK RETURNING 0 - ELSE - GOBACK RETURNING 1 - END-IF - . -]) - -AT_CHECK([$COMPILE prog.cob], [0], [], []) -MANUAL_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) - -AT_CLEANUP - - -AT_SETUP([LEFTLINE]) -AT_KEYWORDS([GRID]) - -AT_SKIP_IF([test "$COB_HAS_CURSES" != "yes"]) - -# Currently not implemented -AT_XFAIL_IF([true]) - -AT_DATA([prog.cob], [ - IDENTIFICATION DIVISION. - PROGRAM-ID. prog. - DATA DIVISION. - WORKING-STORAGE SECTION. - 01 success-flag PIC X VALUE 'Y'. - 88 success VALUE 'Y', 'y'. - - SCREEN SECTION. - 01 scr. - 03 PIC X(80) - VALUE 'Enter "y" if the string has a vertical line to ' - & 'its left:'. - 03 LINE + 1, COL 2, PIC X(10) VALUE 'Leftline' LEFTLINE. - 03 success-field LINE + 2, PIC X, REQUIRED, - USING success-flag. - - PROCEDURE DIVISION. - DISPLAY scr - ACCEPT scr - - IF success AND COB-CRT-STATUS = 0 - GOBACK RETURNING 0 - ELSE - GOBACK RETURNING 1 - END-IF - . -]) - -AT_CHECK([$COMPILE prog.cob], [0], [], []) -MANUAL_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) - -AT_CLEANUP - - -AT_SETUP([LOWLIGHT]) -AT_KEYWORDS([screen]) - -AT_SKIP_IF([test "$COB_HAS_CURSES" != "yes"]) - -AT_DATA([prog.cob], [ - IDENTIFICATION DIVISION. - PROGRAM-ID. prog. - DATA DIVISION. - WORKING-STORAGE SECTION. - 01 success-flag PIC X VALUE 'Y'. - 88 success VALUE 'Y', 'y'. - - SCREEN SECTION. - 01 scr. - 03 PIC X(80) - VALUE 'Enter "y" if the string below is dim (lowlight):'. - 03 LINE + 1, PIC X(10) VALUE 'Lowlight' LOWLIGHT. - 03 success-field LINE + 2, PIC X, REQUIRED, - USING success-flag. - - PROCEDURE DIVISION. - DISPLAY scr - ACCEPT scr - - IF success AND COB-CRT-STATUS = 0 - GOBACK RETURNING 0 - ELSE - GOBACK RETURNING 1 - END-IF - . -]) - -AT_CHECK([$COMPILE prog.cob], [0], [], []) -MANUAL_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) - -AT_CLEANUP - - -AT_SETUP([OVERLINE]) -AT_KEYWORDS([screen]) - -AT_SKIP_IF([test "$COB_HAS_CURSES" != "yes"]) - -# Currently not implemented -AT_XFAIL_IF([true]) - -AT_DATA([prog.cob], [ - IDENTIFICATION DIVISION. - PROGRAM-ID. prog. - DATA DIVISION. - WORKING-STORAGE SECTION. - 01 success-flag PIC X VALUE 'Y'. - 88 success VALUE 'Y', 'y'. - - SCREEN SECTION. - 01 scr. - 03 PIC X(80) - VALUE 'Enter "y" if the string below is overlined:'. - 03 LINE + 1, PIC X(10) VALUE 'Overline' OVERLINE. - 03 success-field LINE + 2, PIC X, REQUIRED, - USING success-flag. - - PROCEDURE DIVISION. - DISPLAY scr - ACCEPT scr - - IF success AND COB-CRT-STATUS = 0 - GOBACK RETURNING 0 - ELSE - GOBACK RETURNING 1 - END-IF - . -]) - -AT_CHECK([$COMPILE prog.cob], [0], [], []) -MANUAL_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) - -AT_CLEANUP - - -AT_SETUP([REVERSE-VIDEO]) -AT_KEYWORDS([screen]) - -AT_SKIP_IF([test "$COB_HAS_CURSES" != "yes"]) - -AT_DATA([prog.cob], [ - IDENTIFICATION DIVISION. - PROGRAM-ID. prog. - DATA DIVISION. - WORKING-STORAGE SECTION. - 01 success-flag PIC X VALUE 'Y'. - 88 success VALUE 'Y', 'y'. - - SCREEN SECTION. - 01 scr. - 03 PIC X(80) - VALUE 'Enter "y" if the background and foreground ' - & 'colours of the string below have'. - 03 LINE + 1, PIC X(80) VALUE 'swapped:'. - 03 LINE + 1, PIC X(20) VALUE 'Reversed colours' - REVERSE-VIDEO. - 03 success-field LINE + 2, PIC X USING success-flag. - - PROCEDURE DIVISION. - DISPLAY scr - ACCEPT scr - - IF success AND COB-CRT-STATUS = 0 - GOBACK RETURNING 0 - ELSE - GOBACK RETURNING 1 - END-IF - . -]) - -AT_CHECK([$COMPILE prog.cob], [0], [], []) -MANUAL_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) - -AT_CLEANUP - - -AT_SETUP([SECURE]) -AT_KEYWORDS([PASSWORD]) - -AT_SKIP_IF([test "$COB_HAS_CURSES" != "yes"]) - -AT_DATA([prog.cob], [ - IDENTIFICATION DIVISION. - PROGRAM-ID. prog. - DATA DIVISION. - WORKING-STORAGE SECTION. - 01 dummy PIC X(10). - 01 success-flag PIC X VALUE 'Y'. - 88 success VALUE 'Y', 'y'. - - SCREEN SECTION. - 01 scr. - 03 PIC X(80) - VALUE 'Enter "y" if text in the field below is replaced ' - & 'with asterisks:'. - 03 LINE + 1, PIC X(10) SECURE TO dummy, PROMPT CHARACTER - "-". - 03 success-field LINE + 2, PIC X, REQUIRED, - USING success-flag. - - PROCEDURE DIVISION. - DISPLAY scr - ACCEPT scr - - IF success AND COB-CRT-STATUS = 0 - GOBACK RETURNING 0 - ELSE - GOBACK RETURNING 1 - END-IF - . -]) - -AT_CHECK([$COMPILE prog.cob], [0], [], []) -MANUAL_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) - -AT_CLEANUP - - -AT_SETUP([SIZE with items]) -AT_KEYWORDS([PROTECTED extensions]) - -AT_SKIP_IF([test "$COB_HAS_CURSES" != "yes"]) - -AT_DATA([prog.cob], [ - IDENTIFICATION DIVISION. - PROGRAM-ID. prog. - DATA DIVISION. - WORKING-STORAGE SECTION. - 01 success-flag PIC X VALUE 'Y'. - 88 success VALUE 'Y', 'y'. - - 01 num-1 PIC 9(5) VALUE 12345. - 01 num-2 PIC X(10) VALUE '12345'. - 01 num-3 PIC 9(4) VALUE 1234. - - 01 four PIC 9 VALUE 4. - - PROCEDURE DIVISION. - DISPLAY 'Enter "y" if you see exactly four rows of 1234, all' - & ' aligned.' LINE 1 - - DISPLAY num-1 LINE 3 COL 3, SIZE 4; - num-2 LINE 4 COL 3, SIZE four; - num-3 LINE 5 COL 3, SIZE 8; - '1234' LINE 6 COL 3, SIZE ZERO - - ACCEPT success-flag LINE 8, REQUIRED UPDATE - - IF success AND COB-CRT-STATUS = 0 - GOBACK RETURNING 0 - ELSE - GOBACK RETURNING 1 - END-IF - . -]) - -AT_CHECK([$COMPILE prog.cob], [0], [], []) -MANUAL_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) - -AT_CLEANUP - - -AT_SETUP([SIZE with figurative constants]) -AT_KEYWORDS([PROTECTED extensions]) - -AT_SKIP_IF([test "$COB_HAS_CURSES" != "yes"]) - -AT_DATA([prog.cob], [ - IDENTIFICATION DIVISION. - PROGRAM-ID. prog. - DATA DIVISION. - WORKING-STORAGE SECTION. - 01 success-flag PIC X VALUE 'Y'. - 88 success VALUE 'Y', 'y'. - - PROCEDURE DIVISION. - DISPLAY 'Enter "y" if you see exactly three rows of quotes, ' - & 'zeroes and ''abc'',', LINE 1 - DISPLAY '8 characters long, all aligned.', LINE 2 - - DISPLAY QUOTES LINE 4 COL 3, SIZE 8; - ZEROES LINE 5 COL 3, SIZE 8; - ALL 'abc' LINE 6 COL 3, SIZE 8 - - DISPLAY '123456789' LINE 7 COL 3 - DISPLAY SPACE LINE 7 COL 3, SIZE 9 - - ACCEPT success-flag LINE 8, REQUIRED UPDATE - - IF success AND COB-CRT-STATUS = 0 - GOBACK RETURNING 0 - ELSE - GOBACK RETURNING 1 - END-IF - . -]) - -AT_CHECK([$COMPILE prog.cob], [0], [], []) -MANUAL_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) - -AT_CLEANUP - - -AT_SETUP([UPDATE]) -AT_KEYWORDS([extensions]) - -AT_SKIP_IF([test "$COB_HAS_CURSES" != "yes"]) - -AT_DATA([prog.cob], [ - IDENTIFICATION DIVISION. - PROGRAM-ID. prog. - DATA DIVISION. - WORKING-STORAGE SECTION. - 01 n-str PIC X(12) VALUE SPACES. - 01 success-flag PIC X. - 88 success VALUE 'Y', 'y'. - - SCREEN SECTION. - 01 scr. - 03 VALUE 'Enter "y" if the entry field below is filled with' - & ' N''s'. - 03 n-field, LINE + 1, PIC X(12) USING n-str. - 03 success-field, LINE + 2, PIC X, REQUIRED, - TO success-flag, FROM 'Y'. - - PROCEDURE DIVISION. - DISPLAY scr - MOVE ALL 'N' TO n-str - ACCEPT scr - - IF success AND COB-CRT-STATUS = 0 - GOBACK RETURNING 0 - ELSE - GOBACK RETURNING 1 - END-IF - . -]) - -AT_CHECK([$COMPILE -fno-accept-update prog.cob], [0], [], []) -MANUAL_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) - -AT_CLEANUP - - -AT_SETUP([UNDERLINE]) -AT_KEYWORDS([screen]) - -AT_SKIP_IF([test "$COB_HAS_CURSES" != "yes"]) - -AT_DATA([prog.cob], [ - IDENTIFICATION DIVISION. - PROGRAM-ID. prog. - DATA DIVISION. - WORKING-STORAGE SECTION. - 01 success-flag PIC X VALUE 'Y'. - 88 success VALUE 'Y', 'y'. - - SCREEN SECTION. - 01 scr. - 03 PIC X(80) - VALUE 'Enter "y" if the string below is underlined:'. - 03 LINE + 1, PIC X(10) VALUE 'Underline' UNDERLINE. - 03 success-field LINE + 2, PIC X, REQUIRED, - USING success-flag. - - PROCEDURE DIVISION. - DISPLAY scr - ACCEPT scr - - IF success AND COB-CRT-STATUS = 0 - GOBACK RETURNING 0 - ELSE - GOBACK RETURNING 1 - END-IF - . -]) - -AT_CHECK([$COMPILE prog.cob], [0], [], []) -MANUAL_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) - -AT_CLEANUP - - -AT_SETUP([SPECIAL-NAMES CURSOR phrase 6-digit with field]) -AT_KEYWORDS([position ACCEPT]) - -AT_SKIP_IF([test "$COB_HAS_CURSES" != "yes"]) - -AT_DATA([prog.cob], [ - IDENTIFICATION DIVISION. - PROGRAM-ID. prog. - ENVIRONMENT DIVISION. - CONFIGURATION SECTION. - SPECIAL-NAMES. - CURSOR IS cur-pos. - DATA DIVISION. - WORKING-STORAGE SECTION. - 77 cur-pos pic 9(06). - 01 success-flag PIC X VALUE 'Y'. - 88 success VALUE 'Y', 'y'. - 01 ws-x-20 PIC X(20). - PROCEDURE DIVISION. - testme. - set environment 'COB_SCREEN_EXCEPTIONS' to 'TRUE' - set environment 'COB_SCREEN_ESC' to 'TRUE' - - DISPLAY "If the cursor below is positioned at the 'C'" - LINE 1 COLUMN 1. - DISPLAY "(third column) below, then position it at the" - LINE 2 COLUMN 1. - DISPLAY "'E' (fifth column) and press ENTER." - LINE 3 COLUMN 1. - - MOVE "ABCDEFG " TO WS-X-20. - MOVE 005003 TO cur-pos. - ACCEPT WS-X-20 - LINE 5 COLUMN 1 - WITH - AUTO-SKIP - SIZE 10 - UPDATE. - - IF cur-pos = 005005 AND COB-CRT-STATUS = 0 - GOBACK RETURNING 0 - ELSE - GOBACK RETURNING 1 - END-IF - . -]) - -AT_CHECK([$COMPILE prog.cob], [0], [], []) -MANUAL_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) - -AT_CLEANUP - - -AT_SETUP([SPECIAL-NAMES CURSOR phrase 4-digit with field]) -AT_KEYWORDS([position ACCEPT]) - -AT_SKIP_IF([test "$COB_HAS_CURSES" != "yes"]) - -AT_DATA([prog.cob], [ - IDENTIFICATION DIVISION. - PROGRAM-ID. prog. - ENVIRONMENT DIVISION. - CONFIGURATION SECTION. - SPECIAL-NAMES. - CURSOR IS cur-pos. - DATA DIVISION. - WORKING-STORAGE SECTION. - 77 cur-pos pic 9(04). - 01 success-flag PIC X VALUE 'Y'. - 88 success VALUE 'Y', 'y'. - 01 ws-x-20 PIC X(20). - PROCEDURE DIVISION. - testme. - set environment 'COB_SCREEN_EXCEPTIONS' to 'TRUE' - set environment 'COB_SCREEN_ESC' to 'TRUE' - - DISPLAY "If the cursor below is positioned at the 'C'" - LINE 1 COLUMN 1. - DISPLAY "(third column) below, then position it at the" - LINE 2 COLUMN 1. - DISPLAY "'E' (fifth column) and press ENTER." - LINE 3 COLUMN 1. - - MOVE "ABCDEFG " TO WS-X-20. - MOVE 0503 TO cur-pos. - ACCEPT WS-X-20 - LINE 5 COLUMN 1 - WITH - AUTO-SKIP - SIZE 10 - UPDATE. - - IF cur-pos = 0505 AND COB-CRT-STATUS = 0 - GOBACK RETURNING 0 - ELSE - GOBACK RETURNING 1 - END-IF - . -]) - -AT_CHECK([$COMPILE prog.cob], [0], [], []) -MANUAL_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) - -AT_CLEANUP - - -AT_SETUP([ACCEPT field WITH CURSOR data-item]) -AT_KEYWORDS([position]) - -AT_SKIP_IF([test "$COB_HAS_CURSES" != "yes"]) - -AT_DATA([prog.cob], [ - IDENTIFICATION DIVISION. - PROGRAM-ID. prog. - DATA DIVISION. - WORKING-STORAGE SECTION. - 77 cur-pos pic 9(04). - 01 success-flag PIC X VALUE 'Y'. - 88 success VALUE 'Y', 'y'. - 01 ws-x-20 PIC X(20). - PROCEDURE DIVISION. - testme. - set environment 'COB_SCREEN_EXCEPTIONS' to 'TRUE' - set environment 'COB_SCREEN_ESC' to 'TRUE' - - DISPLAY "If the cursor below is positioned at the 'C'" - LINE 1 COLUMN 1. - DISPLAY "(third column in field) below, then position it at" - LINE 2 COLUMN 1. - DISPLAY "the 'E' (fifth column) and press ENTER." - LINE 3 COLUMN 1. - - MOVE "ABCDEFG " TO WS-X-20. - MOVE 0003 TO cur-pos. - ACCEPT WS-X-20 - LINE 5 COLUMN 3 - WITH - AUTO-SKIP - SIZE 10 - CURSOR cur-pos - UPDATE. - - IF cur-pos = 0005 AND COB-CRT-STATUS = 0 - GOBACK RETURNING 0 - ELSE - GOBACK RETURNING 1 - END-IF - . -]) - -AT_CHECK([$COMPILE prog.cob], [0], [], []) -MANUAL_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) - -AT_CLEANUP - - -AT_SETUP([ACCEPT field WITH CURSOR size overflow]) -AT_KEYWORDS([position]) - -AT_SKIP_IF([test "$COB_HAS_CURSES" != "yes"]) - -AT_DATA([prog.cob], [ - IDENTIFICATION DIVISION. - PROGRAM-ID. prog. - DATA DIVISION. - WORKING-STORAGE SECTION. - 77 cur-pos pic 9(04). - 01 success-flag PIC X VALUE 'Y'. - 88 success VALUE 'Y', 'y'. - 01 ws-x-20 PIC X(10). - PROCEDURE DIVISION. - testme. - set environment 'COB_SCREEN_EXCEPTIONS' to 'TRUE' - set environment 'COB_SCREEN_ESC' to 'TRUE' - - DISPLAY "If the cursor below is positioned at the last" - LINE 1 COLUMN 1. - DISPLAY "column in the field below, then position it at" - LINE 2 COLUMN 1. - DISPLAY "the 'C' (third column) and press ENTER." - LINE 3 COLUMN 1. - - MOVE "ABCDEFGHIJ" TO WS-X-20. - MOVE 0012 TO cur-pos. - ACCEPT WS-X-20 - LINE 5 COLUMN 3 - WITH - AUTO-SKIP - SIZE 10 - CURSOR cur-pos - UPDATE. - - IF cur-pos = 0003 AND COB-CRT-STATUS = 0 - GOBACK RETURNING 0 - ELSE - GOBACK RETURNING 1 - END-IF - . -]) - -AT_CHECK([$COMPILE prog.cob], [0], [], []) -MANUAL_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) - -AT_CLEANUP - - -AT_SETUP([ACCEPT field WITH CURSOR data overflow I]) -AT_KEYWORDS([position]) - -AT_SKIP_IF([test "$COB_HAS_CURSES" != "yes"]) - -AT_DATA([prog.cob], [ - IDENTIFICATION DIVISION. - PROGRAM-ID. prog. - DATA DIVISION. - WORKING-STORAGE SECTION. - 77 cur-pos pic 9(04). - 01 success-flag PIC X VALUE 'Y'. - 88 success VALUE 'Y', 'y'. - 01 ws-x-20 PIC X(20). - PROCEDURE DIVISION. - testme. - set environment 'COB_SCREEN_EXCEPTIONS' to 'TRUE' - set environment 'COB_SCREEN_ESC' to 'TRUE' - - DISPLAY "If the cursor below is positioned at the 'E'" - LINE 1 COLUMN 1. - DISPLAY "(fifth column in field) below, then position it at" - LINE 2 COLUMN 1. - DISPLAY "the 'C' (third column) and press ENTER." - LINE 3 COLUMN 1. - - MOVE "ABCDE " TO WS-X-20. - MOVE 0008 TO cur-pos. - ACCEPT WS-X-20 - LINE 5 COLUMN 3 - WITH - AUTO-SKIP - SIZE 10 - CURSOR cur-pos - UPDATE. - - IF cur-pos = 0003 AND COB-CRT-STATUS = 0 - GOBACK RETURNING 0 - ELSE - GOBACK RETURNING 1 - END-IF - . -]) - -AT_CHECK([$COMPILE prog.cob], [0], [], []) -MANUAL_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) - -AT_CLEANUP - - -AT_SETUP([ACCEPT field WITH CURSOR data overflow II]) -AT_KEYWORDS([position UNDERLINE]) - -AT_SKIP_IF([test "$COB_HAS_CURSES" != "yes"]) - -AT_DATA([prog.cob], [ - IDENTIFICATION DIVISION. - PROGRAM-ID. prog. - DATA DIVISION. - WORKING-STORAGE SECTION. - 77 cur-pos pic 9(04). - 01 success-flag PIC X VALUE 'Y'. - 88 success VALUE 'Y', 'y'. - 01 ws-x-20 PIC X(20). - PROCEDURE DIVISION. - testme. - set environment 'COB_SCREEN_EXCEPTIONS' to 'TRUE' - set environment 'COB_SCREEN_ESC' to 'TRUE' - - DISPLAY "If the cursor below is positioned at the first" - LINE 1 COLUMN 1. - DISPLAY "column in the field below and it is empty, then" - LINE 2 COLUMN 1. - DISPLAY "enter 'AB', position after the 'B' and press ENTER." - LINE 3 COLUMN 1. - - MOVE "ABCDE " TO WS-X-20. - MOVE 0008 TO cur-pos. - ACCEPT WS-X-20 - LINE 5 COLUMN 3 - WITH - SIZE 10 - UNDERLINE - CURSOR cur-pos. - - IF cur-pos = 0003 AND COB-CRT-STATUS = 0 - GOBACK RETURNING 0 - ELSE - GOBACK RETURNING 1 - END-IF - . -]) - -AT_CHECK([$COMPILE prog.cob], [0], [], []) -MANUAL_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) - -AT_CLEANUP - - -AT_SETUP([ACCEPT field WITH CURSOR literal]) -AT_KEYWORDS([position]) - -AT_SKIP_IF([test "$COB_HAS_CURSES" != "yes"]) - -AT_DATA([prog.cob], [ - IDENTIFICATION DIVISION. - PROGRAM-ID. prog. - DATA DIVISION. - WORKING-STORAGE SECTION. - 01 success-flag PIC X VALUE 'Y'. - 88 success VALUE 'Y', 'y'. - 01 ws-x-20 PIC X(20). - PROCEDURE DIVISION. - testme. - set environment 'COB_SCREEN_EXCEPTIONS' to 'TRUE' - set environment 'COB_SCREEN_ESC' to 'TRUE' - - DISPLAY "If the cursor below is positioned at the 'C'" - LINE 1 COLUMN 1. - DISPLAY "(third column in field) below, then press ENTER." - LINE 2 COLUMN 1. - - MOVE "ABCDEFG " TO WS-X-20. - ACCEPT WS-X-20 - LINE 4 COLUMN 2 - WITH - AUTO-SKIP - SIZE 10 - CURSOR 3 - UPDATE. - - IF COB-CRT-STATUS = 0 - GOBACK RETURNING 0 - ELSE - GOBACK RETURNING 1 - END-IF - . -]) - -AT_CHECK([$COMPILE prog.cob], [0], [], []) -MANUAL_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) - -AT_CLEANUP - - -AT_SETUP([HOME key]) -AT_KEYWORDS([HOME SIZE]) - -AT_SKIP_IF([test "$COB_HAS_CURSES" != "yes"]) - -AT_DATA([prog.cob], [ - IDENTIFICATION DIVISION. - PROGRAM-ID. prog. - DATA DIVISION. - WORKING-STORAGE SECTION. - 01 success-flag PIC X VALUE 'Y'. - 88 success VALUE 'Y', 'y'. - 01 ws-x-20 PIC X(20). - PROCEDURE DIVISION. - DISPLAY "Enter 'y' if multiple presses of the HOME key" - LINE 1 COLUMN 1. - DISPLAY "go to the beginning of the field and the beginning" - LINE 2 COLUMN 1. - DISPLAY "of the characters." - LINE 3 COLUMN 1. - - MOVE " ABC " TO WS-X-20. - ACCEPT WS-X-20 - LINE 5 COLUMN 1 - WITH - AUTO-SKIP - SIZE 10 - UPDATE. - - ACCEPT SUCCESS-FLAG - LINE 7 COLUMN 1 - WITH UPDATE. - - IF success AND COB-CRT-STATUS = 0 - GOBACK RETURNING 0 - ELSE - GOBACK RETURNING 1 - END-IF - . -]) - -AT_CHECK([$COMPILE prog.cob], [0], [], []) -MANUAL_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) - -AT_CLEANUP - - -AT_SETUP([END key]) -AT_KEYWORDS([END SIZE position]) - -AT_SKIP_IF([test "$COB_HAS_CURSES" != "yes"]) - -AT_DATA([prog.cob], [ - IDENTIFICATION DIVISION. - PROGRAM-ID. prog. - DATA DIVISION. - WORKING-STORAGE SECTION. - 01 success-flag PIC X VALUE 'Y'. - 88 success VALUE 'Y', 'y'. - 01 ws-x-20 PIC X(20). - PROCEDURE DIVISION. - DISPLAY "Enter 'y' if multiple presses of the END key" - LINE 1 COLUMN 1. - DISPLAY "go to the end of the field and just after the end" - LINE 2 COLUMN 1. - DISPLAY "of the characters." - LINE 3 COLUMN 1. - - MOVE " ABC " TO WS-X-20. - ACCEPT WS-X-20 - LINE 5 COLUMN 1 - WITH - AUTO-SKIP - SIZE 10 - UPDATE. - - ACCEPT SUCCESS-FLAG - LINE 7 COLUMN 1 - WITH UPDATE. - - IF success AND COB-CRT-STATUS = 0 - GOBACK RETURNING 0 - ELSE - GOBACK RETURNING 1 - END-IF - . -]) - -AT_CHECK([$COMPILE prog.cob], [0], [], []) -MANUAL_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) - -AT_CLEANUP - - -AT_SETUP([INSERT key]) -AT_KEYWORDS([COB_INSERT_MODE SIZE]) - -AT_SKIP_IF([test "$COB_HAS_CURSES" != "yes"]) - -AT_DATA([prog.cob], [ - IDENTIFICATION DIVISION. - PROGRAM-ID. prog. - DATA DIVISION. - WORKING-STORAGE SECTION. - 01 success-flag PIC X VALUE 'Y'. - 88 success VALUE 'Y', 'y'. - 01 ws-x-20 PIC X(20). - PROCEDURE DIVISION. - DISPLAY "Enter 'y' if multiple presses of the INSERT key" - LINE 1 COLUMN 1. - DISPLAY "go back and forth between" - LINE 2 COLUMN 1. - DISPLAY "Insert Mode ON (characters move to the right)" - LINE 3 COLUMN 1. - DISPLAY "and Insert Mode OFF (characters type over)." - LINE 4 COLUMN 1. - - MOVE "ABCD " TO WS-X-20. - ACCEPT WS-X-20 - LINE 6 COLUMN 1 - WITH - AUTO-SKIP - SIZE 10 - UPDATE. - - ACCEPT SUCCESS-FLAG - LINE 8 COLUMN 1 - WITH UPDATE. - - IF success AND COB-CRT-STATUS = 0 - GOBACK RETURNING 0 - ELSE - GOBACK RETURNING 1 - END-IF - . -]) - -AT_CHECK([$COMPILE prog.cob], [0], [], []) -MANUAL_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) - -AT_CLEANUP - - -AT_SETUP([cursor visibility]) -AT_KEYWORDS([COB_HIDE_CURSOR]) - -AT_SKIP_IF([test "$COB_HAS_CURSES" != "yes"]) - -AT_DATA([prog.cob], [ - IDENTIFICATION DIVISION. - PROGRAM-ID. prog. - DATA DIVISION. - WORKING-STORAGE SECTION. - 01 success-flag PIC X VALUE 'Y'. - 88 fail VALUE 'N'. - 01 ws-input PIC X. - 88 success VALUE 'Y', 'y'. - PROCEDURE DIVISION. - DISPLAY "Type 'Y' if you see the cursor" - LINE 1 COLUMN 1. - - ACCEPT WS-INPUT - LINE 1 COLUMN 50 - WITH AUTO-SKIP - UPDATE. - IF NOT success SET fail TO TRUE. - - SET ENVIRONMENT 'COB_HIDE_CURSOR' TO 'TRUE'. - - DISPLAY "Type 'Y' if you do not see the cursor" - LINE 3 COLUMN 1. - - ACCEPT WS-INPUT - LINE 3 COLUMN 50 - WITH AUTO-SKIP - UPDATE. - IF NOT success SET fail TO TRUE. - - SET ENVIRONMENT 'COB_INSERT_MODE' TO 'TRUE'. - - DISPLAY "Type 'Y' if you still do not see the cursor" - LINE 5 COLUMN 1. - - ACCEPT WS-INPUT - LINE 5 COLUMN 50 - WITH AUTO-SKIP - UPDATE. - IF NOT success SET fail TO TRUE. - - IF fail - GOBACK RETURNING 1 - ELSE - GOBACK RETURNING 0 - END-IF - . -]) - -AT_CHECK([$COMPILE prog.cob], [0], [], []) -MANUAL_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) - -AT_CLEANUP - - -AT_SETUP([BACKSPACE key]) -AT_KEYWORDS([SIZE CURSOR position]) - -AT_SKIP_IF([test "$COB_HAS_CURSES" != "yes"]) - -AT_DATA([prog.cob], [ - IDENTIFICATION DIVISION. - PROGRAM-ID. prog. - ENVIRONMENT DIVISION. - CONFIGURATION SECTION. - SPECIAL-NAMES. - CURSOR IS cur-pos. - DATA DIVISION. - WORKING-STORAGE SECTION. - 77 cur-pos pic 9(06). - 01 success-flag PIC X VALUE 'Y'. - 88 success VALUE 'Y', 'y'. - 01 ws-x-20 PIC X(20). - PROCEDURE DIVISION. - DISPLAY "Enter 'y' if each press of the BACKSPACE key" - LINE 1 COLUMN 1. - DISPLAY "deletes the character to the left and moves the" - LINE 2 COLUMN 1. - DISPLAY "cursor and remaining characters one space to the" - LINE 3 COLUMN 1. - DISPLAY "left." - LINE 4 COLUMN 1. - - MOVE "ABCD " TO WS-X-20. - MOVE 006002 TO cur-pos. - ACCEPT WS-X-20 - LINE 6 COLUMN 1 - WITH - AUTO-SKIP - SIZE 10 - UPDATE. - - ACCEPT SUCCESS-FLAG - LINE 8 COLUMN 1 - WITH UPDATE. - - IF success AND COB-CRT-STATUS = 0 - GOBACK RETURNING 0 - ELSE - GOBACK RETURNING 1 - END-IF - . -]) - -AT_CHECK([$COMPILE prog.cob], [0], [], []) -MANUAL_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) - -AT_CLEANUP - - -AT_SETUP([DELETE key]) -AT_KEYWORDS([SIZE position]) - -AT_SKIP_IF([test "$COB_HAS_CURSES" != "yes"]) - -AT_DATA([prog.cob], [ - IDENTIFICATION DIVISION. - PROGRAM-ID. prog. - DATA DIVISION. - WORKING-STORAGE SECTION. - 01 success-flag PIC X VALUE 'Y'. - 88 success VALUE 'Y', 'y'. - 01 ws-x-20 PIC X(20). - PROCEDURE DIVISION. - DISPLAY "Enter 'y' if each press of the DELETE key deletes" - LINE 1 COLUMN 1. - DISPLAY "the cursor character and moves the remaining" - LINE 2 COLUMN 1. - DISPLAY "characters one space to the left. And the cursor" - LINE 3 COLUMN 1. - DISPLAY "does not move." - LINE 4 COLUMN 1. - - MOVE "ABCD " TO WS-X-20. - ACCEPT WS-X-20 - LINE 6 COLUMN 1 - WITH - AUTO-SKIP - SIZE 10 - UPDATE. - - ACCEPT SUCCESS-FLAG - LINE 8 COLUMN 1 - WITH UPDATE. - - IF success AND COB-CRT-STATUS = 0 - GOBACK RETURNING 0 - ELSE - GOBACK RETURNING 1 - END-IF - . -]) - -AT_CHECK([$COMPILE prog.cob], [0], [], []) -MANUAL_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) - -AT_CLEANUP - - -AT_SETUP([ALT DELETE key]) -AT_KEYWORDS([ALT-DELETE SIZE]) - -AT_SKIP_IF([test "$COB_HAS_CURSES" != "yes"]) - -AT_DATA([prog.cob], [ - IDENTIFICATION DIVISION. - PROGRAM-ID. prog. - DATA DIVISION. - WORKING-STORAGE SECTION. - 01 success-flag PIC X VALUE 'Y'. - 88 success VALUE 'Y', 'y'. - 01 ws-x-20 PIC X(20). - PROCEDURE DIVISION. - DISPLAY "Enter 'y' if pressing the ALT and DELETE keys" - LINE 1 COLUMN 1. - DISPLAY "deletes all characters from the cursor to the end" - LINE 2 COLUMN 1. - DISPLAY "of the field. And the cursor does not move." - LINE 3 COLUMN 1. - - MOVE "ABCD " TO WS-X-20. - ACCEPT WS-X-20 - LINE 5 COLUMN 1 - WITH - AUTO-SKIP - SIZE 10 - UPDATE. - - ACCEPT SUCCESS-FLAG - LINE 7 COLUMN 1 - WITH UPDATE. - - IF success AND COB-CRT-STATUS = 0 - GOBACK RETURNING 0 - ELSE - GOBACK RETURNING 1 - END-IF - . -]) - -AT_CHECK([$COMPILE prog.cob], [0], [], []) -MANUAL_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) - -AT_CLEANUP - - -AT_SETUP([ALT LEFT-ARROW key]) -AT_KEYWORDS([ALT-LEFT-ARROW SIZE]) - -AT_SKIP_IF([test "$COB_HAS_CURSES" != "yes"]) - -AT_DATA([prog.cob], [ - IDENTIFICATION DIVISION. - PROGRAM-ID. prog. - DATA DIVISION. - WORKING-STORAGE SECTION. - 01 success-flag PIC X VALUE 'Y'. - 88 success VALUE 'Y', 'y'. - 01 ws-x-20 PIC X(20). - PROCEDURE DIVISION. - DISPLAY "Enter 'y' if pressing the ALT and LEFT-ARROW keys" - LINE 1 COLUMN 1. - DISPLAY "at the first column does not exit the field." - LINE 2 COLUMN 1. - DISPLAY "But the LEFT-ARROW without ALT does exit." - LINE 3 COLUMN 1. - - MOVE "ABCD " TO WS-X-20. - ACCEPT WS-X-20 - LINE 5 COLUMN 1 - WITH - AUTO-SKIP - SIZE 10 - UPDATE. - - ACCEPT SUCCESS-FLAG - LINE 7 COLUMN 1 - WITH UPDATE. - - IF success AND COB-CRT-STATUS = 0 - GOBACK RETURNING 0 - ELSE - GOBACK RETURNING 1 - END-IF - . -]) - -AT_CHECK([$COMPILE prog.cob], [0], [], []) -MANUAL_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) - -AT_CLEANUP - - -AT_SETUP([ALT RIGHT-ARROW key]) -AT_KEYWORDS([SIZE]) - -AT_SKIP_IF([test "$COB_HAS_CURSES" != "yes"]) - -AT_DATA([prog.cob], [ - IDENTIFICATION DIVISION. - PROGRAM-ID. prog. - DATA DIVISION. - WORKING-STORAGE SECTION. - 01 success-flag PIC X VALUE 'Y'. - 88 success VALUE 'Y', 'y'. - 01 ws-x-10 PIC X(10). - PROCEDURE DIVISION. - DISPLAY "Enter 'y' if pressing the ALT and RIGHT-ARROW keys" - LINE 1 COLUMN 1. - DISPLAY "at the last column does not exit the field." - LINE 2 COLUMN 1. - DISPLAY "But the RIGHT-ARROW without ALT does exit." - LINE 3 COLUMN 1. - - MOVE "ABCDE" TO WS-X-10. - ACCEPT WS-X-10 - LINE 5 COLUMN 1 - WITH - AUTO-SKIP - SIZE 5 - UPDATE. - - ACCEPT SUCCESS-FLAG - LINE 7 COLUMN 1 - WITH UPDATE. - - IF success AND COB-CRT-STATUS = 0 - GOBACK RETURNING 0 - ELSE - GOBACK RETURNING 1 - END-IF - . -]) - -AT_CHECK([$COMPILE prog.cob], [0], [], []) -MANUAL_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) - -AT_CLEANUP - - -AT_SETUP([CURSOR clause]) -AT_KEYWORDS([SPECIAL-NAMES]) - -AT_SKIP_IF([test "$COB_HAS_CURSES" != "yes"]) - -AT_DATA([prog1.cob], [ - identification division. - program-id. prog. - - environment division. - configuration section. - special-names. - cursor is my-cur. - data division. - working-storage section. - - 01 my-cur. - 05 my-row pic 9(3) value 0. - 05 my-col pic 9(3) value 0. - - 77 loop pic 99. - 77 cursor-moves-here pic x(20). - - screen section. - - 01 screen-example . - 05 message1 value is "row (view only) is " line 1 col 10. - 05 filler pic 9(3) from my-row. - - 05 message2 value is "col (adjust only) is " line 2 col 10. - 05 filler pic 9(3) using my-col. - - 05 filler pic x(20) using cursor-moves-here line 3 col 14. - - procedure division. - - perform varying loop from 1 by 1 - until loop > 10 - display "screen accept no. " - at line 10 col 4 - loop "/10" - display screen-example - accept screen-example - end-perform - - goback. -]) - -# note: same test, but this time with different specified -# special-names reference -AT_DATA([prog2.cob], [ - identification division. - program-id. prog. - - data division. - working-storage section. - - 01 my-cur is special-names cursor. - 05 my-row pic 9(3) value 0. - 05 my-col pic 9(3) value 0. - - 77 loop pic 99. - 77 cursor-moves-here pic x(20). - - screen section. - - 01 screen-example . - 05 message1 value is "row (view only) is " line 1 col 10. - 05 filler pic 9(3) from my-row. - - 05 message2 value is "col (adjust only) is " line 2 col 10. - 05 filler pic 9(3) using my-col. - - 05 filler pic x(20) using cursor-moves-here line 3 col 14. - - procedure division. - - perform varying loop from 1 by 1 - until loop > 10 - display "screen accept no. " - at line 10 col 4 - loop "/10" - display screen-example - accept screen-example - end-perform - - goback. -]) - -AT_CHECK([$COMPILE prog1.cob], [0], [], []) -AT_CHECK([$COMPILE prog2.cob], [0], [], []) - -# user-instructions what to test is missing -AT_SKIP_IF([true]) - -MANUAL_CHECK([$COBCRUN_DIRECT ./prog1], [0], [], []) -MANUAL_CHECK([$COBCRUN_DIRECT ./prog2], [0], [], []) - -AT_CLEANUP - - -AT_SETUP([CRT STATUS clause]) -AT_KEYWORDS([SPECIAL-NAMES]) - -AT_SKIP_IF([test "$COB_HAS_CURSES" != "yes"]) - -AT_DATA([prog1.cob], [ - identification division. - program-id. prog. - - environment division. - configuration section. - special-names. - crt status is my-status. - data division. - working-storage section. - - 01 my-status. - 05 one pic X. - 05 two pic X. - 05 three pic X. - 05 four pic X. - - 77 loop pic 99. - 77 test-field pic x(5). - - screen section. - - 01 screen-example . - 05 message1 value is "status: " line 1 col 10. - 05 filler pic x(4) from my-status. - - 05 message2 value is "test-field: " line 2 col 10. - 05 filler pic x(5) using test-field. - - procedure division. - - set environment 'COB_SCREEN_EXCEPTIONS' to 'TRUE' - set environment 'COB_SCREEN_ESC' to 'TRUE' - perform varying loop from 1 by 1 - until loop > 10 - display "screen accept no. " - at line 10 col 4 - loop "/10" - display screen-example - accept screen-example - end-perform - - goback. -]) - -# note: same test, but this time with different specified -# special-names reference -AT_DATA([prog2.cob], [ - identification division. - program-id. prog. - - data division. - working-storage section. - - 77 my-status pic 9(05) is special-names crt status. - - 77 loop pic 99. - 77 test-field pic x(5). - - screen section. - - 01 screen-example . - 05 message1 value is "status: " line 1 col 10. - 05 filler pic 9(05) from my-status. - - 05 message2 value is "test-field: " line 2 col 10. - 05 filler pic x(5) using test-field. - - procedure division. - - set environment 'COB_SCREEN_EXCEPTIONS' to 'TRUE' - set environment 'COB_SCREEN_ESC' to 'TRUE' - perform varying loop from 1 by 1 - until loop > 10 - display "screen accept no. " - at line 10 col 4 - loop "/10" - display screen-example - accept screen-example - end-perform - - goback. -]) - -AT_CHECK([$COMPILE prog1.cob], [0], [], []) -AT_CHECK([$COMPILE prog2.cob], [0], [], []) - -# user-instructions what to test is missing -AT_SKIP_IF([true]) - -MANUAL_CHECK([$COBCRUN_DIRECT ./prog1], [0], [], []) -MANUAL_CHECK([$COBCRUN_DIRECT ./prog2], [0], [], []) - -AT_CLEANUP - - -AT_SETUP([CRT STATUS clause]) -AT_KEYWORDS([SPECIAL-NAMES]) - -AT_SKIP_IF([test "$COB_HAS_CURSES" != "yes"]) - -AT_DATA([prog.cob], [ - identification division. - program-id. prog-crt4. - - data division. - working-storage section. - - 01 crt4 pic 9(4) is special-names crt status. - - 01 test-tab. - 05 test-01 pic x(20) value "Function key 01 1001". - 05 test-02 pic x(20) value "Function key 02 1002". - 05 test-03 pic x(20) value "Function key 03 1003". - 05 test-04 pic x(20) value "Function key 04 1004". - 05 test-05 pic x(20) value "Function key 05 1005". - 05 test-06 pic x(20) value "Prev-page key 2001". - 05 test-07 pic x(20) value "Next-page key 2002". - - 01 test-rab-r redefines test-tab. - 05 test-data occurs 7 times. - 10 test-name pic x(16). - 10 test-crt4 pic 9(4). - - 01 linenr pic 9(2) value 0. - - 01 test-result-4 pic 9(4). - - 01 return-value pic 9 value 0. - - 77 loop pic 9(2). - 77 test-field pic x. - - - procedure division. - - set environment 'COB_SCREEN_EXCEPTIONS' to 'TRUE' - set environment 'COB_SCREEN_ESC' to 'TRUE' - - perform forever - display spaces with blank screen - - move 0 to return-value - perform varying loop from 1 by 1 until loop > 7 - compute linenr = loop + 5 - - display "Please press " line linenr, column 1 - display test-name(loop) line linenr, column 14 - - move spaces to test-field - accept test-field - line linenr column 30 - - display crt4 line linenr, column 30 - - if crt4 = test-crt4(loop) - display "passed" line linenr, column 36 - else - move 1 to return-value - display "failed" line linenr, column 36 - end-if - end-perform - - if return-value = 0 - exit perform - end-if - - display "Try again? (Y/n) " line 20, column 1 - move "Y" to test-field - accept test-field line 20, column 18 - if not (test-field = "Y" or "y") - exit perform - end-if - end-perform - - goback returning return-value - . -]) - -AT_CHECK([$COMPILE prog.cob], [0], [], []) - -MANUAL_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) - -AT_CLEANUP - - -AT_SETUP([X/Open CRT STATUS clause]) -AT_KEYWORDS([SPECIAL-NAMES]) - -AT_SKIP_IF([test "$COB_HAS_CURSES" != "yes"]) - -AT_DATA([prog.cob], [ - identification division. - program-id. prog-crt3. - - data division. - working-storage section. - - 01 crt3 is special-names crt status. - 05 crt3-1 pic 9. - 05 crt3-2 usage binary-char unsigned. - 05 crt3-3 usage binary-char unsigned. - - 01 test-tab. - 05 test-01 pic x(20) value "Function key 01 1001". - 05 test-02 pic x(20) value "Function key 02 1002". - 05 test-03 pic x(20) value "Function key 03 1003". - 05 test-04 pic x(20) value "Function key 04 1004". - 05 test-05 pic x(20) value "Function key 05 1005". - 05 test-06 pic x(20) value "Prev-page key 2001". - 05 test-07 pic x(20) value "Next-page key 2002". - - 01 test-rab-r redefines test-tab. - 05 test-data occurs 7 times. - 10 test-name pic x(16). - 10 test-crt31 pic 9. - 10 test-crt32 pic 9(3). - - 01 linenr pic 9(2) value 0. - - 01 test-result-1 pic 9. - 01 test-result-3 pic 9(3). - - 01 return-value pic 9 value 0. - - 77 loop pic 9(2). - 77 test-field pic x. - - - procedure division. - - set environment 'COB_SCREEN_EXCEPTIONS' to 'TRUE' - set environment 'COB_SCREEN_ESC' to 'TRUE' - - perform forever - display spaces with blank screen - - move 0 to return-value - perform varying loop from 1 by 1 until loop > 7 - compute linenr = loop + 5 - - display "Please press " line linenr, column 1 - display test-name(loop) line linenr, column 14 - - move spaces to test-field - accept test-field - line linenr column 30 - - move crt3-1 to test-result-1 - display test-result-1 line linenr, column 30 - - move crt3-2 to test-result-3 - display test-result-3 line linenr, column 32 - - if test-result-1 = test-crt31(loop) and - test-result-3 = test-crt32(loop) - display "passed" line linenr, column 36 - else - move 1 to return-value - display "failed" line linenr, column 36 - end-if - end-perform - - if return-value = 0 - exit perform - end-if - - display "Try again? (Y/n) " line 20, column 1 - move "Y" to test-field - accept test-field line 20, column 18 - if not (test-field = "Y" or "y") - exit perform - end-if - end-perform - - goback returning return-value - . -]) - -AT_CHECK([$COMPILE prog.cob], [0], [], []) - -MANUAL_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) - -AT_CLEANUP - -AT_SETUP([simple ACCEPT field WITH UPDATE]) -AT_KEYWORDS([screen]) - -AT_SKIP_IF([test "$COB_HAS_CURSES" != "yes"]) - -AT_DATA([prog.cob], [ - IDENTIFICATION DIVISION. - PROGRAM-ID. prog. - DATA DIVISION. - WORKING-STORAGE SECTION. - 77 var pic x(11) value 'ignore this'. - 01 success-flag PIC X VALUE 'y'. - 88 success VALUE 'Y', 'y'. - - PROCEDURE DIVISION. - display "Press ENTER if you see an ""y"" " - at 0302 - accept success-flag update. - - IF success AND COB-CRT-STATUS = 0 - GOBACK RETURNING 0 - ELSE - GOBACK RETURNING 1 - END-IF - . -]) - -AT_CHECK([$COMPILE prog.cob], [0], [], []) -MANUAL_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) - -AT_CLEANUP - - -AT_SETUP([VALUE ALL in SCREEN SECTION]) - -AT_SKIP_IF([test "$COB_HAS_CURSES" != "yes"]) - -AT_DATA([prog.cob], [ - IDENTIFICATION DIVISION. - PROGRAM-ID. SCREEN-VALUE-ALL. - - DATA DIVISION. - WORKING-STORAGE SECTION. - - SCREEN SECTION. - 01 SCREEN001 BLANK SCREEN AUTO-SKIP. - 03 SCR01 BACKGROUND-COLOR 2 FOREGROUND-COLOR 7. - 05 LINE 02 COL 001 PIC X(50) VALUE ALL '-'. - - PROCEDURE DIVISION. - DISPLAY 'Press ENTER if you see a sequence of ""-""' - AT 0101 END-DISPLAY - DISPLAY ' ' AT 0201 END-DISPLAY - ACCEPT SCREEN001 - ACCEPT OMITTED - GOBACK. -]) - -AT_CHECK([$COMPILE prog.cob], [0], [], []) -MANUAL_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) - -AT_CLEANUP - - -AT_SETUP([CURSOR position in line 1]) -AT_KEYWORDS([screen]) - -AT_SKIP_IF([test "$COB_HAS_CURSES" != "yes"]) - -AT_DATA([prog.cob], [ - IDENTIFICATION DIVISION. - PROGRAM-ID. PROG. - ENVIRONMENT DIVISION. - CONFIGURATION SECTION. - SPECIAL-NAMES. - CURSOR IS CURSOR-POSITION. - - DATA DIVISION. - - WORKING-STORAGE SECTION. - - 01 CURSOR-POSITION. - 05 CSR-ROW-NUMBER PIC 9(03) VALUE 001. - 05 CSR-COL-NUMBER PIC 9(03) VALUE 005. - - 01 WORK-FIELDS. - 05 IN-ID PIC X(09) VALUE SPACES. - 05 TRAN-ID PIC X(03) VALUE 'ABC'. - - 01 SUCCESS-FLAG PIC X VALUE 'Y'. - 88 SUCCESS VALUE 'y', 'Y'. - - SCREEN SECTION. - - 01 EMPLOYEE-SCREEN - BACKGROUND-COLOR IS 0 - FOREGROUND-COLOR IS 7. - - 05 LINE 01 COL 01 AUTO PIC X(03) USING - TRAN-ID. - 05 LINE 01 COL 04 PIC X(01) VALUE - ','. - 05 LINE 01 COL 05 AUTO PIC X(09) USING - IN-ID. - - 05 LINE 5 VALUE 'cursor should be ' - & 'at line 1 and column 5'. - 05 LINE 6 VALUE 'go to line 10 ' - & 'and enter an "y" or "n" '. - 05 LINE 10 PIC X, REQUIRED USING success-flag. - - PROCEDURE DIVISION. - - DISPLAY EMPLOYEE-SCREEN. - ACCEPT EMPLOYEE-SCREEN. - - IF SUCCESS AND COB-CRT-STATUS = 0 - GOBACK RETURNING 0 - ELSE - GOBACK RETURNING 1 - END-IF. - -]) - -AT_CHECK([$COMPILE prog.cob], [0], [], []) -MANUAL_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) - -AT_CLEANUP - - -AT_SETUP([ACCEPT SCREEN TIMEOUT]) -AT_KEYWORDS([crt status cursor]) - -AT_SKIP_IF([test "$COB_HAS_CURSES" != "yes"]) - -AT_DATA([prog.cob], [ - REPLACE ==:BCOL:== BY ==BACKGROUND-COLOR==; ==:FCOL:== BY - ==FOREGROUND-COLOR==. - ** ************************************************************* - ** - ** ************************************************************* - IDENTIFICATION DIVISION. - PROGRAM-ID. PROG. - * GnuCOBOL sample - ENVIRONMENT DIVISION. - CONFIGURATION SECTION. - SPECIAL-NAMES. - CRT STATUS IS WCRT-STATUS. - CURSOR IS WCURSORROWCOL. - DATA DIVISION. - - WORKING-STORAGE SECTION. - 77 K-ENTER PIC 9(04) VALUE 0000. - 77 K-TIMEOUT PIC 9(04) VALUE 8001. - - 01 WCRT-STATUS PIC 9(04) VALUE ZERO. - 01 WCURSORROWCOL PIC 9(06) VALUE 000000. - 01 REDEFINES WCURSORROWCOL . - 05 WCURSORROW PIC 9(03). - 05 WCURSORCOL PIC 9(03). - 01 BLACK CONSTANT AS 00. - 01 BLUE CONSTANT AS 01. - 01 GREEN CONSTANT AS 02. - 01 CYAN CONSTANT AS 03. - 01 RED CONSTANT AS 04. - 01 MAGENTA CONSTANT AS 05. - * old color code as yellow - 01 BROWN CONSTANT AS 06. - * or Light Gray - 01 WHITE CONSTANT AS 07. - * or Dark Gray - 01 GREY CONSTANT AS 08. - * same color code as Grey - 01 LIGHTBLACK CONSTANT AS 08. - 01 LIGHTBLUE CONSTANT AS 09. - 01 LIGHTGREEN CONSTANT AS 10. - 01 LIGHTCYAN CONSTANT AS 11. - 01 LIGHTRED CONSTANT AS 12. - 01 LIGHTMAGENTA CONSTANT AS 13. - 01 PINK CONSTANT AS 13. - 01 YELLOW CONSTANT AS 14. - 01 LIGHTWHITE CONSTANT AS 15. - - - - 01 W-VAR-SELECTION. - 02 W-DATA PIC X(8). - 02 W-REPLY PIC X(01). - 88 SUCCESS VALUE 'Y', 'y'. - - - SCREEN SECTION. - - 01 SCREEN-SELECTION. - 02 LINE 06 COL 05 :FCOL: BLACK :BCOL: CYAN - VALUE 'TIMEOUT TEST - ENTER 4 CHARACTERS OF DATA' & - ' AND PAUSE UNTIL TIME CHANGES'. - 02 LINE 07 COL 05 :FCOL: BLACK :BCOL: CYAN - VALUE ' THEN ENTER 4 MORE CHARACTERS OF DATA' & - ' AND PAUSE UNTIL TIME CHANGES'. - 02 LINE 08 COL 05 :FCOL: BLACK :BCOL: CYAN - VALUE ' THEN AFTER THE TIME CHANGES ' & - ' ENTER A Y IN THE REPY LINE IF THE DATA ' & - ' IS CORRECT'. - - 02 LINE 15 COL 20 VALUE 'Data Entry:'. - 02 LINE + 2 COL 20 VALUE 'Reply:'. - 02 LINE 15 COL 40 PIC A(08) AUTO-SKIP USING W-DATA - HIGHLIGHT. - 02 LINE + 2 COL 40 PIC X AUTO-SKIP USING W-REPLY - HIGHLIGHT. - - PROCEDURE DIVISION. - - MAIN-LOOP. - DISPLAY SCREEN-SELECTION - CALL 'TIMEDISP' - - PERFORM WITH TEST AFTER UNTIL WCRT-STATUS <> K-TIMEOUT - ACCEPT SCREEN-SELECTION WITH TIMEOUT 1 - ON EXCEPTION CALL 'TIMEDISP' - END-ACCEPT - END-PERFORM. - - IF SUCCESS AND WCRT-STATUS = 0 - GOBACK RETURNING 0 - ELSE - GOBACK RETURNING 1 - END-IF - . - - GOBACK. - - ** ************************************************************* - * - ** ************************************************************* - ID DIVISION. - PROGRAM-ID. TIMEDISP. - DATA DIVISION. - WORKING-STORAGE SECTION. - 01 SWITCH PIC X. - 01 BLUE CONSTANT AS 01. - 01 RED CONSTANT AS 04. - 01 CYAN CONSTANT AS 03. - 01 WHITE CONSTANT AS 07. - 01 WDAY PIC 9(08). - 01 WTIME PIC 9(08). - 01 DATE-TIME PIC X(19). - PROCEDURE DIVISION. - ACCEPT WDAY FROM DATE YYYYMMDD - ACCEPT WTIME FROM TIME - STRING WDAY(1:4) '.' WDAY(5:2) '.' WDAY(7:2) ' ' - WTIME(1:2) ':' WTIME(3:2) ':' WTIME(5:2) DELIMITED BY - SIZE INTO DATE-TIME - IF SWITCH EQUAL 'N' - DISPLAY DATE-TIME AT 002061 :BCOL: CYAN :FCOL: WHITE - END-DISPLAY - MOVE 'Y' TO SWITCH - ELSE - DISPLAY DATE-TIME AT 002061 :BCOL: RED :FCOL: WHITE - END-DISPLAY - MOVE 'N' TO SWITCH - END-IF. - CONTINUE. - ENDPROGRAM. - GOBACK. - END PROGRAM TIMEDISP. - - END PROGRAM PROG. -]) - -AT_CHECK([$COMPILE prog.cob], [0], [], []) -MANUAL_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) - -AT_CLEANUP +## Copyright (C) 2014-2018,2020-2024 Free Software Foundation, Inc. +## Written by Edward Hart, Simon Sobisch, Chuck Haatvedt +## +## This file is part of GnuCOBOL. +## +## The GnuCOBOL compiler is free software: you can redistribute it +## and/or modify it under the terms of the GNU General Public License +## as published by the Free Software Foundation, either version 3 of the +## License, or (at your option) any later version. +## +## GnuCOBOL is distributed in the hope that it will be useful, +## but WITHOUT ANY WARRANTY; without even the implied warranty of +## MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +## GNU General Public License for more details. +## +## You should have received a copy of the GNU General Public License +## along with GnuCOBOL. If not, see . + +### GnuCOBOL Test Suite + +### ISO+IEC+1989-2014 9.2 Screens, 13.17 Screen description entry, 13.18 Data +### division clauses. + +AT_SETUP([LINE]) +AT_KEYWORDS([screen]) + +AT_SKIP_IF([test "$COB_HAS_CURSES" != "yes"]) + +AT_DATA([prog.cob], [ + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 success-flag PIC X VALUE 'Y'. + 88 success VALUE 'Y', 'y'. + + SCREEN SECTION. + 01 scr. + 03 LINE 1 VALUE 'Enter "y" if the numbers below correspond ' + & 'to their line number and are in the '. + 03 LINE 2 VALUE 'first column. (This is line 2.)'. + 03 LINE 3 VALUE '3'. + 03 LINE 4 VALUE '4'. + 03 LINE 5 VALUE '5'. + 03 group-1 LINE - 3. + 05 group-2 COL 5. + 07 LINE PLUS 6 VALUE '8'. + 07 LINE MINUS 2 VALUE '6'. + 03 group-3 LINE + 1. + 05 COL 1 VALUE '7'. + 03 LINE + 3 PIC X, REQUIRED USING success-flag. + + PROCEDURE DIVISION. + DISPLAY scr + ACCEPT scr + + IF success AND COB-CRT-STATUS = 0 + GOBACK RETURNING 0 + ELSE + GOBACK RETURNING 1 + END-IF + . +]) + +AT_CHECK([$COMPILE prog.cob], [0], [], []) +MANUAL_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) + +AT_CLEANUP + + +AT_SETUP([COLUMN (1)]) +AT_KEYWORDS([COL]) + +AT_SKIP_IF([test "$COB_HAS_CURSES" != "yes"]) + +AT_DATA([prog.cob], [ + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 dummy PIC X(5). + 01 success-flag PIC X VALUE 'Y'. + 88 success VALUE 'Y', 'y'. + + SCREEN SECTION. + 01 scr. + 03 VALUE 'Enter "y" if the numbers below correspond to ' + & 'their column number.'. + 03 LINE 2 VALUE '123456789'. + 03 LINE 3 COLUMN 2. + 05 COL 1 VALUE '1'. + 05 COL 5 VALUE '5'. + 05 COL MINUS 2 VALUE '3'. + 05 COL PLUS 1 VALUE '4'. + 05 group-1 LINE 3. + 07 VALUE '2'. + 07 group-2 COLUMN + 4. + 09 group-3. + 11 COL + 0 VALUE '6'. + 05 COLUMN + 1, VALUE '7'. + 03 LINE 5 PIC X, REQUIRED, USING success-flag. + + PROCEDURE DIVISION. + DISPLAY scr + ACCEPT scr + + IF success AND COB-CRT-STATUS = 0 + GOBACK RETURNING 0 + ELSE + GOBACK RETURNING 1 + END-IF + . +]) + +AT_CHECK([$COMPILE prog.cob], [0], [], []) +MANUAL_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) + +AT_CLEANUP + + +AT_SETUP([COLUMN (2)]) +AT_KEYWORDS([COL]) + +AT_SKIP_IF([test "$COB_HAS_CURSES" != "yes"]) + +AT_DATA([prog.cob], [ + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 dummy-1 PIC X(10). + 01 dummy-2 PIC X(10). + 01 dummy-3 PIC X(10). + + 01 success-flag PIC X VALUE 'Y'. + 88 success VALUE 'Y', 'y'. + + SCREEN SECTION. + 01 scr. + 03 PIC X(80) VALUE 'Enter "y" if there are three non-'- + 'overlapping input fields on one line below.'. + 03 LINE + 1, PIC X(80) VALUE 'field.'. + 03 LINE + 2, PIC X(10) TO dummy-1. + 03 COL + 2, PIC X(10) TO dummy-2. + 03 COL + 2, PIC X(10) TO dummy-3. + 03 success-field LINE + 2, PIC X, REQUIRED, + USING success-flag. + + PROCEDURE DIVISION. + DISPLAY scr + ACCEPT scr + + IF success AND COB-CRT-STATUS = 0 + GOBACK RETURNING 0 + ELSE + GOBACK RETURNING 1 + END-IF + . +]) + +AT_CHECK([$COMPILE prog.cob], [0], [], []) +MANUAL_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) + +AT_CLEANUP + + +AT_SETUP([LINE non-zero, COLUMN zero]) +AT_KEYWORDS([COL extensions]) + +AT_SKIP_IF([test "$COB_HAS_CURSES" != "yes"]) + +AT_DATA([prog.cob], [ + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 success-flag PIC X VALUE 'Y'. + 88 success VALUE 'Y', 'y'. + + SCREEN SECTION. + 01 scr. + 03 LINE 1 VALUE 'Enter "y" if you see 123 on the line '- + 'below starting at column 1.'. + 03 LINE + 3 PIC X, REQUIRED USING success-flag. + 03 LINE 2 VALUE '1'. + + PROCEDURE DIVISION. + DISPLAY scr + DISPLAY '2' LINE 2, COLUMN 0; '3' + ACCEPT scr + + IF success AND COB-CRT-STATUS = 0 + GOBACK RETURNING 0 + ELSE + GOBACK RETURNING 1 + END-IF + . +]) + +AT_CHECK([$COMPILE prog.cob], [0], [], []) +MANUAL_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) + +AT_CLEANUP + + +AT_SETUP([LINE zero, COLUMN non-zero]) +AT_KEYWORDS([COL zero extensions]) + +AT_SKIP_IF([test "$COB_HAS_CURSES" != "yes"]) + +AT_DATA([prog.cob], [ + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 success-flag PIC X VALUE 'Y'. + 88 success VALUE 'Y', 'y'. + + SCREEN SECTION. + 01 scr. + 03 LINE 1 VALUE 'Enter "y" if you see 123 on the line '- + 'below starting at column 1.'. + 03 LINE + 3 PIC X, REQUIRED USING success-flag. + 03 LINE 2 COL 3, VALUE '3'. + 03 LINE 1 COL 80 VALUE ' '. + + PROCEDURE DIVISION. + DISPLAY scr + DISPLAY '1' LINE 0, COLUMN 1; '2' + ACCEPT scr + + IF success AND COB-CRT-STATUS = 0 + GOBACK RETURNING 0 + ELSE + GOBACK RETURNING 1 + END-IF + . +]) + +AT_CHECK([$COMPILE prog.cob], [0], [], []) +MANUAL_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) + +AT_CLEANUP + + +AT_SETUP([LINE zero, COLUMN zero]) +AT_KEYWORDS([COL extensions]) + +AT_SKIP_IF([test "$COB_HAS_CURSES" != "yes"]) + +AT_DATA([prog.cob], [ + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 success-flag PIC X VALUE 'Y'. + 88 success VALUE 'Y', 'y'. + + SCREEN SECTION. + 01 scr. + 03 LINE 1 VALUE 'Enter "y" if you see 1234 on the line '- + 'below starting at column 1.'. + 03 LINE + 3 PIC X, REQUIRED USING success-flag. + 03 LINE 2 VALUE '1'. + + PROCEDURE DIVISION. + DISPLAY scr + DISPLAY '2' LINE 0, COLUMN 0 + DISPLAY '3' LINE 2, COLUMN 3 + DISPLAY '4' AT 0000 + + ACCEPT scr + + IF success AND COB-CRT-STATUS = 0 + GOBACK RETURNING 0 + ELSE + GOBACK RETURNING 1 + END-IF + . +]) + +AT_CHECK([$COMPILE prog.cob], [0], [], []) +MANUAL_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) + +AT_CLEANUP + + +AT_SETUP([DISPLAY AT]) +AT_KEYWORDS([extensions]) + +AT_SKIP_IF([test "$COB_HAS_CURSES" != "yes"]) + +AT_DATA([prog.cob], [ + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 success-flag PIC X VALUE 'Y'. + 88 success VALUE 'Y', 'y'. + + 01 screen-loc PIC 9(6) VALUE 4004. + + SCREEN SECTION. + 01 scr. + 03 VALUE 'Enter "y" if the numbers 1-3 are in a diagonal'- + ' line from line 2, column 2.'. + 03 success-field PIC X, LINE 6, REQUIRED, + USING success-flag. + + PROCEDURE DIVISION. + DISPLAY '1' AT 0202 + DISPLAY '2' AT 003003 + DISPLAY '3' AT screen-loc + DISPLAY scr + ACCEPT scr + + IF success AND COB-CRT-STATUS = 0 + GOBACK RETURNING 0 + ELSE + GOBACK RETURNING 1 + END-IF + . +]) + +AT_CHECK([$COMPILE prog.cob], [0], [], []) +MANUAL_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) + +AT_CLEANUP + + +AT_SETUP([DISPLAY LOW-VALUES (one statement)]) +AT_KEYWORDS([LOW-VALUE extensions]) + +AT_SKIP_IF([test "$COB_HAS_CURSES" != "yes"]) + +AT_DATA([prog.cob], [ + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 success-flag PIC X VALUE 'Y'. + 88 success VALUE 'Y', 'y'. + + SCREEN SECTION. + 01 scr. + 03 LINE 1 VALUE 'Enter "y" if the word below starts at line' + & ' 3, column 3.'. + 03 LINE + 4 PIC X, REQUIRED USING success-flag. + + PROCEDURE DIVISION. + DISPLAY scr + DISPLAY LOW-VALUES AT LINE 3, COL 3; 'Hello!' + ACCEPT scr + + IF success AND COB-CRT-STATUS = 0 + GOBACK RETURNING 0 + ELSE + GOBACK RETURNING 1 + END-IF + . +]) + +AT_CHECK([$COMPILE prog.cob], [0], [], []) +MANUAL_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) + +AT_CLEANUP + + +AT_SETUP([DISPLAY LOW-VALUES (two statements)]) +AT_KEYWORDS([LOW-VALUE extensions]) + +AT_SKIP_IF([test "$COB_HAS_CURSES" != "yes"]) + +AT_DATA([prog.cob], [ + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 success-flag PIC X VALUE 'Y'. + 88 success VALUE 'Y', 'y'. + + SCREEN SECTION. + 01 scr. + 03 LINE 1 VALUE 'Enter "y" if the word below starts at line' + & ' 3, column 3.'. + 03 LINE + 4 PIC X, REQUIRED USING success-flag. + + PROCEDURE DIVISION. + DISPLAY scr + DISPLAY LOW-VALUES AT LINE 3, COL 3 + DISPLAY 'Hello!' UPON CRT + ACCEPT scr + + IF success AND COB-CRT-STATUS = 0 + GOBACK RETURNING 0 + ELSE + GOBACK RETURNING 1 + END-IF + . +]) + +AT_CHECK([$COMPILE prog.cob], [0], [], []) +MANUAL_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) + +AT_CLEANUP + + +AT_SETUP([DISPLAY SPACES]) +AT_KEYWORDS([SPACE extensions]) + +AT_SKIP_IF([test "$COB_HAS_CURSES" != "yes"]) + +AT_DATA([prog.cob], [ + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 success-flag PIC X VALUE 'Y'. + 88 success VALUE 'Y', 'y'. + + SCREEN SECTION. + 01 scr-1. + 03 LINE 1 VALUE 'Enter "y" if all the text after foo in the' + & ' screen has been erased.'. + 03 LINE 3 VALUE 'Lorem ipsum dolor sit amet, consectetur ad' + & 'ipiscing elit. Curabitur dapibus dui'. + 03 LINE 4 VALUE 'vitae augue lobortis, non tempor diam tris' + & 'tique. Donec dignissim ex velit, ut'. + 03 LINE 5 VALUE 'efficitur tellus pharetra at. Curabitur at' + & ' condimentum nunc, nec accumsan'. + 03 LINE 6 VALUE 'nulla. Nulla at feugiat elit, eget condime' + & 'ntum justo. Nam lorem lectus,'. + 03 LINE 7 VALUE 'imperdiet sit amet odio eu, eleifend conse' + & 'ctetur ligula. Duis diam felis, porta'. + 03 LINE 8 VALUE 'id diam id, ultrices finibus augue. Mauris' + & ' imperdiet, dolor sed sodales porta,'. + 03 LINE 9 VALUE 'justo nunc consequat nulla, iaculis venena' + & 'tis lorem libero sit amet'. + 03 LINE 10 VALUE 'magna. Nullam pulvinar nullam.'. + 03 success-field LINE + 2, PIC X, REQUIRED, + USING success-flag. + + PROCEDURE DIVISION. + DISPLAY scr-1 + DISPLAY SPACES AT LINE 6, COL 8; 'foo' HIGHLIGHT + ACCEPT success-field + + IF success AND COB-CRT-STATUS = 0 + GOBACK RETURNING 0 + ELSE + GOBACK RETURNING 1 + END-IF + . +]) + +AT_CHECK([$COMPILE -fdisplay-special-fig-consts prog.cob], [0], [], []) +MANUAL_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) + +AT_CLEANUP + + +AT_SETUP([DISPLAY ALL X'01']) +AT_KEYWORDS([SOH extensions]) + +AT_SKIP_IF([test "$COB_HAS_CURSES" != "yes"]) + +AT_DATA([prog.cob], [ + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 success-flag PIC X VALUE 'Y'. + 88 success VALUE 'Y', 'y'. + + SCREEN SECTION. + 01 scr-1. + 03 LINE 1 VALUE 'Enter "y" if all the text after foo on ' + & 'that line alone has been erased.'. + 03 LINE 3 VALUE 'Lorem ipsum dolor sit amet, consectetur ad' + & 'ipiscing elit. Curabitur dapibus dui'. + 03 LINE 4 VALUE 'vitae augue lobortis, non tempor diam tris' + & 'tique. Donec dignissim ex velit, ut'. + 03 LINE 5 VALUE 'efficitur tellus pharetra at. Curabitur at' + & ' condimentum nunc, nec accumsan'. + 03 LINE 6 VALUE 'nulla. Nulla at feugiat elit, eget condime' + & 'ntum justo. Nam lorem lectus,'. + 03 LINE 7 VALUE 'imperdiet sit amet odio eu, eleifend conse' + & 'ctetur ligula. Duis diam felis, porta'. + 03 LINE 8 VALUE 'id diam id, ultrices finibus augue. Mauris' + & ' imperdiet, dolor sed sodales porta,'. + 03 LINE 9 VALUE 'justo nunc consequat nulla, iaculis venena' + & 'tis lorem libero sit amet'. + 03 LINE 10 VALUE 'magna. Nullam pulvinar nullam.'. + 03 success-field LINE + 2, PIC X, REQUIRED, + USING success-flag. + + PROCEDURE DIVISION. + DISPLAY scr-1 + DISPLAY ALL X'01', LINE 6, COLUMN 8; 'foo' HIGHLIGHT + ACCEPT success-field + + IF success AND COB-CRT-STATUS = 0 + GOBACK RETURNING 0 + ELSE + GOBACK RETURNING 1 + END-IF + . +]) + +AT_CHECK([$COMPILE -fdisplay-special-fig-consts prog.cob], [0], [], []) +MANUAL_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) + +AT_CLEANUP + + +AT_SETUP([DISPLAY ALL X'02']) +AT_KEYWORDS([STX extensions]) + +AT_SKIP_IF([test "$COB_HAS_CURSES" != "yes"]) + +AT_DATA([prog.cob], [ + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 success-flag PIC X VALUE 'Y'. + 88 success VALUE 'Y', 'y'. + + SCREEN SECTION. + 01 scr-1. + 03 LINE 3 VALUE 'Lorem ipsum dolor sit amet, consectetur ad' + & 'ipiscing elit. Curabitur dapibus dui'. + 03 LINE 4 VALUE 'vitae augue lobortis, non tempor diam tris' + & 'tique. Donec dignissim ex velit, ut'. + 03 LINE 5 VALUE 'efficitur tellus pharetra at. Curabitur at' + & ' condimentum nunc, nec accumsan'. + 03 LINE 6 VALUE 'nulla. Nulla at feugiat elit, eget condime' + & 'ntum justo. Nam lorem lectus,'. + 03 LINE 7 VALUE 'imperdiet sit amet odio eu, eleifend conse' + & 'ctetur ligula. Duis diam felis, porta'. + 03 LINE 8 VALUE 'id diam id, ultrices finibus augue. Mauris' + & ' imperdiet, dolor sed sodales porta,'. + 03 LINE 9 VALUE 'justo nunc consequat nulla, iaculis venena' + & 'tis lorem libero sit amet'. + 03 LINE 10 VALUE 'magna. Nullam pulvinar nullam.'. + + 01 scr-2. + 03 LINE 6 COL 8 VALUE 'foo' BLANK SCREEN, HIGHLIGHT. + 03 LINE 1 VALUE 'Enter "y" if foo is the only word below.'. + + 01 scr-3. + 03 VALUE 'Enter "y" if foo is the only word below.'. + 03 success-field COL + 2, PIC X, REQUIRED, + USING success-flag. + + PROCEDURE DIVISION. + DISPLAY scr-1 + DISPLAY ALL X'02' AT LINE 6 COL 8; 'foo' HIGHLIGHT + DISPLAY scr-3 + ACCEPT scr-3 + + IF success AND COB-CRT-STATUS = 0 + GOBACK RETURNING 0 + ELSE + GOBACK RETURNING 1 + END-IF + . +]) + +AT_CHECK([$COMPILE -fdisplay-special-fig-consts prog.cob], [0], [], []) +MANUAL_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) + +AT_CLEANUP + + +AT_SETUP([DISPLAY ALL X'07']) +AT_KEYWORDS([BELL BEEP extensions]) + +AT_SKIP_IF([test "$COB_HAS_CURSES" != "yes"]) + +AT_DATA([prog.cob], [ + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 success-flag PIC X. + 88 success VALUE 'Y', 'y'. + + SCREEN SECTION. + 01 scr. + 03 VALUE 'Enter "y" if you heard a beep:'. + 03 success-field PIC X, COL + 2, REQUIRED, TO success-flag + FROM 'Y'. + 01 scr2. + 03 LINE 4 VALUE 'system beep may be turned off ' & + 'on this system.'. + 03 LINE 5 VALUE 'Retesting with COB_BELL=FLASH...'. + 03 LINE + 2 + VALUE 'Enter "y" if you''ve seen your terminal flash'. + 03 success-field PIC X, COL + 2, REQUIRED, TO success-flag + FROM 'Y'. + + PROCEDURE DIVISION. + DISPLAY scr + DISPLAY ALL X'07' UPON CRT + ACCEPT scr + + IF success AND COB-CRT-STATUS = 0 + GOBACK RETURNING 0 + END-IF + + SET ENVIRONMENT 'COB_BELL' TO 'FLASH' + CALL 'C$SLEEP' USING '1' + + DISPLAY scr2 + DISPLAY ALL X'07' UPON CRT + ACCEPT scr2 + + IF success AND COB-CRT-STATUS = 0 + GOBACK RETURNING 0 + ELSE + GOBACK RETURNING 1 + END-IF + . +]) + +AT_CHECK([$COMPILE -fdisplay-special-fig-consts prog.cob], [0], [], []) +MANUAL_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) + +AT_CLEANUP + + +AT_SETUP([Screen position after field display]) +AT_KEYWORDS([LINE COLUMN]) + +AT_SKIP_IF([test "$COB_HAS_CURSES" != "yes"]) + +AT_DATA([prog.cob], [ + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 success-flag PIC X VALUE 'Y'. + 88 success VALUE 'Y', 'y'. + + SCREEN SECTION. + 01 scr. + 03 VALUE 'Enter "y" if this sentence starts at line 1,'- + ' column 1:'. + 03 success-field PIC X, COL + 2, REQUIRED, + USING success-flag. + + PROCEDURE DIVISION. + DISPLAY 'ignore this' AT LINE 4 COL 4 + DISPLAY scr + ACCEPT success-field + + IF success AND COB-CRT-STATUS = 0 + GOBACK RETURNING 0 + ELSE + GOBACK RETURNING 1 + END-IF + . +]) + +AT_CHECK([$COMPILE prog.cob], [0], [], []) +MANUAL_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) + +AT_CLEANUP + +# See section 13.17.3 + +AT_SETUP([Overridden clauses (1)]) +AT_KEYWORDS([LINE COLUMN COL]) + +AT_SKIP_IF([test "$COB_HAS_CURSES" != "yes"]) + +AT_DATA([prog.cob], [ + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 dummy PIC X(5). + 01 success-flag PIC X VALUE 'Y'. + 88 success VALUE 'Y', 'y'. + + SCREEN SECTION. + 01 scr. + 03 VALUE 'Enter "y" if the numbers below correspond to their' + & ' column number and all on'. + 03 LINE 2 VALUE 'lines 3 and 4.'. + 03 LINE 3 VALUE '123456789'. + 03 LINE 4 VALUE ' 34'. + 03 FILLER LINE + 6. + 05 COL 3. + 07 COL 1. + 09 LINE 4 VALUE '1'. + 09 VALUE '2'. + 05 LINE + 1, COL + 2. + 07 LINE 4, COL + 1, VALUE '5'. + 03 LINE 6 PIC X, REQUIRED, USING success-flag. + + PROCEDURE DIVISION. + DISPLAY scr + ACCEPT scr + + IF success AND COB-CRT-STATUS = 0 + GOBACK RETURNING 0 + ELSE + GOBACK RETURNING 1 + END-IF + . +]) + +AT_CHECK([$COMPILE prog.cob], [0], [], []) +MANUAL_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) + +AT_CLEANUP + + +AT_SETUP([Overridden clauses (2)]) +AT_KEYWORDS([HIGHLIGHT LOWLIGHT BACKGROUND COLOR COLOUR]) + +AT_SKIP_IF([test "$COB_HAS_CURSES" != "yes"]) + +AT_DATA([prog.cob], [ + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 dummy PIC X(5). + 01 success-flag PIC X VALUE 'Y'. + 88 success VALUE 'Y', 'y'. + + SCREEN SECTION. + 01 scr. + 03 VALUE 'Enter "y" if the word below is not dim and has' + & ' black background.'. + 03 LINE + 1, LOWLIGHT BACKGROUND-COLOR 3. + 05 HIGHLIGHT BACKGROUND-COLOR 0. + 07 VALUE 'Highlight'. + 03 LINE + 2, PIC X USING success-flag. + + PROCEDURE DIVISION. + DISPLAY scr + ACCEPT scr + + IF success AND COB-CRT-STATUS = 0 + GOBACK RETURNING 0 + ELSE + GOBACK RETURNING 1 + END-IF + . +]) + +AT_CHECK([$COMPILE prog.cob], [0], [], []) +MANUAL_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) + +AT_CLEANUP + + +AT_SETUP([AUTO]) +AT_KEYWORDS([position]) + +AT_SKIP_IF([test "$COB_HAS_CURSES" != "yes"]) + +AT_DATA([prog.cob], [ + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 dummy PIC X(5). + 01 success-flag PIC X. + 88 success VALUE 'Y', 'y'. + + SCREEN SECTION. + 01 scr. + 03 PIC X(80) VALUE 'Enter "y" in the bottom' + & ' field if:'. + 03 LINE + 1, PIC X(80) VALUE ' * when the left field is' + & ' full, the cursor automatically moves'. + 03 LINE + 1, PIC X(80) VALUE ' to the next field.'. + 03 LINE + 1, PIC X(80) VALUE ' * this does not happen' + & ' with the other fields.'. + 03 LINE + 1, PIC X(80) VALUE ' * the fields below are' + & ' on one line and separated by a single' + & ' column.'. + + 03 test-fields LINE + 2. + 05 field-1 COL 1, PIC X(5) AUTO TO dummy. + 05 field-2 COL + 2, PIC X(5) TO dummy. + 05 field-3 COL + 2, PIC X(5) TO dummy. + 03 success-field LINE + 2, COLUMN 1; PIC X, REQUIRED + TO success-flag FROM 'Y'. + + PROCEDURE DIVISION. + DISPLAY scr + ACCEPT scr + + IF success AND COB-CRT-STATUS = 0 + GOBACK RETURNING 0 + ELSE + GOBACK RETURNING 1 + END-IF + . +]) + +AT_CHECK([$COMPILE prog.cob], [0], [], []) +MANUAL_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) + +AT_CLEANUP + + +AT_SETUP([SCREEN BACKGROUND- / FOREGROUND-COLOUR]) +AT_KEYWORDS([BACKGROUND-COLOR BACKGROUND-COLOUR FOREGROUND-COLOR +COLOR COLOUR HIGHLIGHT BLINK]) + +AT_SKIP_IF([test "$COB_HAS_CURSES" != "yes"]) + +AT_DATA([prog.cob], [ + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 dummy PIC X(10). + 01 success-flag PIC X. + 88 success VALUE 'Y', 'y'. + + SCREEN SECTION. + 01 scr. + 03 PIC X(80) + VALUE 'Enter "y" if the text below matches the colour ' + & 'of the background/text.'. + 03 LINE + 1, COL 1, PIC X(80) + VALUE 'Note: the black text is on white background/the ' + & 'white background has black text'. + 03 LINE + 1, COL 1, PIC X(80) + VALUE 'to make the text visible.'. + + 03 LINE + 1. + 05 COL 1, PIC X(08) VALUE 'Black' FOREGROUND-COLOR 0 + BACKGROUND-COLOR 7. + 05 COL + 2, PIC X(08) VALUE 'Blue' FOREGROUND-COLOR 1. + 05 COL + 2, PIC X(08) VALUE 'Green' FOREGROUND-COLOR 2. + 05 COL + 2, PIC X(08) VALUE 'Cyan' FOREGROUND-COLOR 3. + 05 COL + 2, PIC X(08) VALUE 'Red' FOREGROUND-COLOR 4. + 05 COL + 2, PIC X(08) VALUE 'Magenta' FOREGROUND-COLOR 5. + 05 COL + 2, PIC X(15) VALUE 'Brown/Yellow' + FOREGROUND-COLOR 6. + 05 COL + 2, PIC X(08) VALUE 'White' FOREGROUND-COLOR 7. + + 03 LINE + 1. + 05 COL 1, PIC X(08) VALUE 'Black' BACKGROUND-COLOR 0 + FOREGROUND-COLOR 7. + 05 COL + 2, PIC X(08) VALUE 'Blue' BACKGROUND-COLOR 1. + 05 COL + 2, PIC X(08) VALUE 'Green' BACKGROUND-COLOR 2. + 05 COL + 2, PIC X(08) VALUE 'Cyan' BACKGROUND-COLOR 3. + 05 COL + 2, PIC X(08) VALUE 'Red' BACKGROUND-COLOR 4. + 05 COL + 2, PIC X(08) VALUE 'Magenta' BACKGROUND-COLOR 5. + 05 COL + 2, PIC X(15) VALUE 'Brown/Yellow' + BACKGROUND-COLOR 6. + 05 COL + 2, PIC X(08) VALUE 'White' BACKGROUND-COLOR 7 + FOREGROUND-COLOR 0. + + 03 LINE + 2. + 03 PIC X(80) + VALUE 'The following is the same as above, ' + & 'with "extended" attributes set;'. + 03 LINE + 1, COL 1, PIC X(80) + VALUE 'this should have the same effect as otherwise ' + & 'highlighted for the first line'. + 03 LINE + 1, COL 1, PIC X(80) + VALUE 'and blinking for the second one.'. + + 03 LINE + 1. + 05 COL 1, PIC X(08) VALUE 'Black' FOREGROUND-COLOR 8 + BACKGROUND-COLOR 0. + 05 COL + 2, PIC X(08) VALUE 'Blue' FOREGROUND-COLOR 9. + 05 COL + 2, PIC X(08) VALUE 'Green' FOREGROUND-COLOR 10. + 05 COL + 2, PIC X(08) VALUE 'Cyan' FOREGROUND-COLOR 11. + 05 COL + 2, PIC X(08) VALUE 'Red' FOREGROUND-COLOR 12. + 05 COL + 2, PIC X(08) VALUE 'Magenta' FOREGROUND-COLOR 13. + 05 COL + 2, PIC X(15) VALUE 'Brown/Yellow' + FOREGROUND-COLOR 14. + 05 COL + 2, PIC X(08) VALUE 'White' FOREGROUND-COLOR 15. + + 03 LINE + 1. + 05 COL 1, PIC X(08) VALUE 'Black' BACKGROUND-COLOR 8 + FOREGROUND-COLOR 15. + 05 COL + 2, PIC X(08) VALUE 'Blue' BACKGROUND-COLOR 9. + 05 COL + 2, PIC X(08) VALUE 'Green' BACKGROUND-COLOR 10. + 05 COL + 2, PIC X(08) VALUE 'Cyan' BACKGROUND-COLOR 11. + 05 COL + 2, PIC X(08) VALUE 'Red' BACKGROUND-COLOR 12. + 05 COL + 2, PIC X(08) VALUE 'Magenta' BACKGROUND-COLOR 13. + 05 COL + 2, PIC X(15) VALUE 'Brown/Yellow' + BACKGROUND-COLOR 14. + 05 COL + 2, PIC X(08) VALUE 'White' BACKGROUND-COLOR 15 + FOREGROUND-COLOR 8. + + 03 success-field LINE + 2, COL 1, PIC X, REQUIRED, + TO success-flag FROM 'Y'. + + PROCEDURE DIVISION. + DISPLAY scr + ACCEPT scr + + IF success AND COB-CRT-STATUS = 0 + GOBACK RETURNING 0 + ELSE + GOBACK RETURNING 1 + END-IF + . +]) + +AT_CHECK([$COMPILE prog.cob], [0], [], []) +MANUAL_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) + +AT_CLEANUP + + +AT_SETUP([SCREEN BACKGROUND- / FOREGROUND-COLOUR via COLOR]) +AT_KEYWORDS([BACKGROUND-COLOR BACKGROUND-COLOUR FOREGROUND-COLOR +COLOR COLOUR REVERSED]) + +# Currently not implemented +AT_XFAIL_IF([true]) + +AT_SKIP_IF([test "$COB_HAS_CURSES" != "yes"]) + +AT_DATA([prog.cob], [ + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 dummy PIC X(10). + 01 success-flag PIC X. + 88 success VALUE 'Y', 'y'. + 77 CBLACK PIC 9(05) VALUE 1. + 77 CBLUE PIC 9(05) VALUE 2. + 77 CGREEN PIC 9(05) VALUE 3. + 77 CCYAN PIC 9(05) VALUE 4. + 77 CRED PIC 9(05) VALUE 5. + 77 CMAGENTA PIC 9(05) VALUE 6. + 77 CYELLOW PIC 9(05) VALUE 7. + 77 CWHITE PIC 9(05) VALUE 8. + + SCREEN SECTION. + 01 scr. + 03 PIC X(80) + VALUE 'Enter "y" if the text below matches the colour ' + & 'of the background/text.'. + 03 LINE + 1, COL 1, PIC X(80) + VALUE 'Note: the black text is on white background/the ' + & 'white background has black text'. + 03 LINE + 1, COL 1, PIC X(80) + VALUE 'to make the text visible.'. + + 03 LINE + 1. + 05 COL 1, PIC X(08) VALUE 'Black' COLOR CBLACK. + 05 COL + 2, PIC X(08) VALUE 'Blue' COLOR CBLUE. + 05 COL + 2, PIC X(08) VALUE 'Green' COLOR CGREEN. + 05 COL + 2, PIC X(08) VALUE 'Cyan' COLOR CCYAN. + 05 COL + 2, PIC X(08) VALUE 'Red' COLOR CRED. + 05 COL + 2, PIC X(08) VALUE 'Magenta' COLOR CMAGENTA. + 05 COL + 2, PIC X(15) VALUE 'Brown/Yellow' + COLOR CYELLOW. + 05 COL + 2, PIC X(08) VALUE 'White' COLOR CWHITE. + + 01 scr2. + 03 LINE 5. + 05 COL 1, PIC X(08) VALUE 'Black' BACKGROUND-COLOR 0 + FOREGROUND-COLOR 7. + 05 COL + 2, PIC X(08) VALUE 'Blue' BACKGROUND-COLOR 1. + 05 COL + 2, PIC X(08) VALUE 'Green' BACKGROUND-COLOR 2. + 05 COL + 2, PIC X(08) VALUE 'Cyan' BACKGROUND-COLOR 3. + 05 COL + 2, PIC X(08) VALUE 'Red' BACKGROUND-COLOR 4. + 05 COL + 2, PIC X(08) VALUE 'Magenta' BACKGROUND-COLOR 5. + 05 COL + 2, PIC X(15) VALUE 'Brown/Yellow' + BACKGROUND-COLOR 6. + 05 COL + 2, PIC X(08) VALUE 'White' BACKGROUND-COLOR 7 + FOREGROUND-COLOR 0. + + 03 success-field LINE + 2, COL 1, PIC X, REQUIRED, + TO success-flag FROM 'Y'. + + PROCEDURE DIVISION. + ADD 256 TO CBLACK + DISPLAY scr + ADD 1024 TO CBLACK, CBLUE, CGREEN, CCYAN, + CRED, CMAGENTA, CYELLOW, CWHITE + DISPLAY scr2 + ACCEPT scr + + IF success AND COB-CRT-STATUS = 0 + GOBACK RETURNING 0 + ELSE + GOBACK RETURNING 1 + END-IF + . +]) + +AT_CHECK([$COMPILE prog.cob], [0], [], []) +MANUAL_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) + +AT_CLEANUP + + +AT_SETUP([field BACKGROUND- / FOREGROUND-COLOUR]) +AT_KEYWORDS([BACKGROUND-COLOR BACKGROUND-COLOUR FOREGROUND-COLOR +COLOR COLOUR HIGHLIGHT BLINK]) + +AT_SKIP_IF([test "$COB_HAS_CURSES" != "yes"]) + +AT_DATA([prog.cob], [ + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 dummy PIC X(10). + 01 success-flag PIC X. + 88 success VALUE 'Y', 'y'. + + SCREEN SECTION. + 01 scr. + 03 PIC X(80) + VALUE 'Enter "y" if the text below matches the colour ' + & 'of the background/text.'. + 03 LINE + 1, COL 1, PIC X(80) + VALUE 'Note: the black text is on white background/the ' + & 'white background has black text'. + 03 LINE + 1, COL 1, PIC X(80) + VALUE 'to make the text visible.'. + + 03 LINE + 1. + 05 COL 1, PIC X(08) VALUE 'Black' FOREGROUND-COLOR 0 + BACKGROUND-COLOR 7. + 05 COL + 2, PIC X(08) VALUE 'Blue' FOREGROUND-COLOR 1. + 05 COL + 2, PIC X(08) VALUE 'Green' FOREGROUND-COLOR 2. + 05 COL + 2, PIC X(08) VALUE 'Cyan' FOREGROUND-COLOR 3. + 05 COL + 2, PIC X(08) VALUE 'Red' FOREGROUND-COLOR 4. + 05 COL + 2, PIC X(08) VALUE 'Magenta' FOREGROUND-COLOR 5. + 05 COL + 2, PIC X(15) VALUE 'Brown/Yellow' + FOREGROUND-COLOR 6. + 05 COL + 2, PIC X(08) VALUE 'White' FOREGROUND-COLOR 7. + + 03 LINE + 1. + 05 COL 1, PIC X(08) VALUE 'Black' BACKGROUND-COLOR 0 + FOREGROUND-COLOR 7. + 05 COL + 2, PIC X(08) VALUE 'Blue' BACKGROUND-COLOR 1. + 05 COL + 2, PIC X(08) VALUE 'Green' BACKGROUND-COLOR 2. + 05 COL + 2, PIC X(08) VALUE 'Cyan' BACKGROUND-COLOR 3. + 05 COL + 2, PIC X(08) VALUE 'Red' BACKGROUND-COLOR 4. + 05 COL + 2, PIC X(08) VALUE 'Magenta' BACKGROUND-COLOR 5. + 05 COL + 2, PIC X(15) VALUE 'Brown/Yellow' + BACKGROUND-COLOR 6. + 05 COL + 2, PIC X(08) VALUE 'White' BACKGROUND-COLOR 7 + FOREGROUND-COLOR 0. + + 03 LINE + 2. + 03 PIC X(80) + VALUE 'The following is the same as above, ' + & 'with "extended" attributes set;'. + 03 LINE + 1, COL 1, PIC X(80) + VALUE 'this should have the same effect as otherwise ' + & 'highlighted for the first line'. + 03 LINE + 1, COL 1, PIC X(80) + VALUE 'and blinking for the second one.'. + + 03 LINE + 1. + 05 COL 1, PIC X(08) VALUE 'Black' FOREGROUND-COLOR 8 + BACKGROUND-COLOR 0. + 05 COL + 2, PIC X(08) VALUE 'Blue' FOREGROUND-COLOR 9. + 05 COL + 2, PIC X(08) VALUE 'Green' FOREGROUND-COLOR 10. + 05 COL + 2, PIC X(08) VALUE 'Cyan' FOREGROUND-COLOR 11. + 05 COL + 2, PIC X(08) VALUE 'Red' FOREGROUND-COLOR 12. + 05 COL + 2, PIC X(08) VALUE 'Magenta' FOREGROUND-COLOR 13. + 05 COL + 2, PIC X(15) VALUE 'Brown/Yellow' + FOREGROUND-COLOR 14. + 05 COL + 2, PIC X(08) VALUE 'White' FOREGROUND-COLOR 15. + + 03 LINE + 1. + 05 COL 1, PIC X(08) VALUE 'Black' BACKGROUND-COLOR 8 + FOREGROUND-COLOR 15. + 05 COL + 2, PIC X(08) VALUE 'Blue' BACKGROUND-COLOR 9. + 05 COL + 2, PIC X(08) VALUE 'Green' BACKGROUND-COLOR 10. + 05 COL + 2, PIC X(08) VALUE 'Cyan' BACKGROUND-COLOR 11. + 05 COL + 2, PIC X(08) VALUE 'Red' BACKGROUND-COLOR 12. + 05 COL + 2, PIC X(08) VALUE 'Magenta' BACKGROUND-COLOR 13. + 05 COL + 2, PIC X(15) VALUE 'Brown/Yellow' + BACKGROUND-COLOR 14. + 05 COL + 2, PIC X(08) VALUE 'White' BACKGROUND-COLOR 15 + FOREGROUND-COLOR 8. + + 03 success-field LINE + 2, COL 1, PIC X, REQUIRED, + TO success-flag FROM 'Y'. + + PROCEDURE DIVISION. + DISPLAY scr + ACCEPT scr + + IF success AND COB-CRT-STATUS = 0 + GOBACK RETURNING 0 + ELSE + GOBACK RETURNING 1 + END-IF + . +]) + +AT_CHECK([$COMPILE prog.cob], [0], [], []) +MANUAL_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) + +AT_CLEANUP + + +AT_SETUP([field BACKGROUND- / FOREGROUND-COLOUR via COLOR]) +AT_KEYWORDS([BACKGROUND-COLOR BACKGROUND-COLOUR FOREGROUND-COLOR +COLOR COLOUR REVERSED HIGHLIGHT BLINK]) + +AT_SKIP_IF([test "$COB_HAS_CURSES" != "yes"]) + +AT_DATA([prog.cob], [ + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 success-flag PIC X VALUE 'Y'. + 88 success VALUE 'Y', 'y'. + + 77 CBLACK PIC 9(05) COMP-5 VALUE 1. + 77 CBLUE PIC 9(05) COMP-5 VALUE 2. + 77 CGREEN PIC 9(05) COMP-5 VALUE 3. + 77 CCYAN PIC 9(05) COMP-5 VALUE 4. + 77 CRED PIC 9(05) COMP-5 VALUE 5. + 77 CMAGENTA PIC 9(05) COMP-5 VALUE 6. + 77 CYELLOW PIC 9(05) COMP-5 VALUE 7. + 77 CWHITE PIC 9(05) COMP-5 VALUE 8. + + 77 LIN PIC 99 COMP-5. + + 01 scr1 PIC X(80) + VALUE 'Enter "y" if the text below matches the colour ' + & 'of the background/text.'. + 01 scr2 PIC X(80) + VALUE 'Note: the black text is on white background/the ' + & 'white background has black text'. + 01 scr3 PIC X(80) + VALUE 'to make the text visible.'. + 01 scr8 PIC X(80) + VALUE 'following lines should be identical but ' + & 'highlighted for the first line'. + 01 scr9 PIC X(80) + VALUE 'and blinking for the second one.'. + + 01 scrblack PIC X(08) VALUE 'Black'. + 01 scrblue PIC X(08) VALUE 'Blue'. + 01 scrgreen PIC X(08) VALUE 'Green'. + 01 scrcyan PIC X(08) VALUE 'Cyan'. + 01 scrred PIC X(08) VALUE 'Red'. + 01 scrmaggy PIC X(08) VALUE 'Magenta'. + 01 scryell PIC X(14) VALUE 'Brown/Yellow'. + 01 scrwhite PIC X(08) VALUE 'White'. + + PROCEDURE DIVISION. + testme. + ADD 256 TO CBLACK + DISPLAY scr1 AT 0102 + DISPLAY scr2 AT 0202 + DISPLAY scr3 AT 0303 + MOVE 5 TO LIN + PERFORM dspcol + ADD 1024 TO CBLACK, CBLUE, CGREEN, CCYAN, + CRED, CMAGENTA, CYELLOW, CWHITE + MOVE 6 TO LIN + PERFORM dspcol + SUBTRACT 1024 FROM CBLACK, CBLUE, CGREEN, CCYAN, + CRED, CMAGENTA, CYELLOW, CWHITE + * + DISPLAY scr8 AT 0802 + DISPLAY scr9 AT 0903 + ADD 4096 TO CBLACK, CBLUE, CGREEN, CCYAN, + CRED, CMAGENTA, CYELLOW, CWHITE + MOVE 11 TO LIN + PERFORM dspcol + SUBTRACT 4096 FROM CBLACK, CBLUE, CGREEN, CCYAN, + CRED, CMAGENTA, CYELLOW, CWHITE + ADD 1024, 16384 TO CBLACK, CBLUE, CGREEN, CCYAN, + CRED, CMAGENTA, CYELLOW, CWHITE + MOVE 12 TO LIN + PERFORM dspcol + * + ACCEPT success-flag AT 1401 UPDATE REQUIRED + + IF success AND COB-CRT-STATUS = 0 + GOBACK RETURNING 0 + ELSE + GOBACK RETURNING 1. + + dspcol. + DISPLAY scrblack LINE LIN COL 1, COLOR CBLACK. + DISPLAY scrblue LINE LIN COL 11, COLOR CBLUE. + DISPLAY scrgreen LINE LIN COL 21, COLOR CGREEN. + DISPLAY scrcyan LINE LIN COL 31, COLOR CCYAN. + DISPLAY scrred LINE LIN COL 41, COLOR CRED. + DISPLAY scrmaggy LINE LIN COL 51, COLOR CMAGENTA. + DISPLAY scryell LINE LIN COL 61, COLOR CYELLOW. + DISPLAY scrwhite LINE LIN COL 77, COLOR CWHITE. +]) + +AT_CHECK([$COMPILE prog.cob], [0], [], []) +MANUAL_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) + +AT_CLEANUP + + +AT_SETUP([field BACKGROUND- / FOREGROUND-COLOUR via CONTROL]) +AT_KEYWORDS([screen DISPLAY REVERSED HIGHLIGHT BLINK COLOR +BACKGROUND-COLOR BACKGROUND-COLOUR FOREGROUND-COLOR COLOUR]) + +AT_SKIP_IF([test "$COB_HAS_CURSES" != "yes"]) + +AT_DATA([prog.cob], [[ + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 success-flag PIC X VALUE 'Y'. + 88 success VALUE 'Y', 'y'. + + * ACU: "=", names only + 77 CBLACK PIC X(99) VALUE "FCOLOR=BLACK, " + & "BCOLOR=WHITE,". + 77 CBLUE PIC X(99) VALUE "FCOLOR=BLUE , " + & "BCOLOR=BLACK,". + * MF: "IS" or "=" or " ", also extended color numbers + 77 CGREEN PIC X(99) VALUE "FCOLOR IS GREEN, " + & "BCOLOR BLACK,". + 77 CCYAN PIC X(99) VALUE "FCOLOR =CYAN, " + & "BCOLOR= BLACK, ". + 77 CRED PIC X(99) VALUE "FCOLOR=RED " + & "BCOLOR=BLACK, ". + 77 CMAGENTA PIC X(99) VALUE "FCOLOR=MAGENTA, " + & "BCOLOR=BLACK,". + 77 CYELLOW PIC X(99) VALUE "FCOLOR = 6, " + & "BCOLOR=BLACK,". + 77 CWHITE PIC X(99) VALUE "FCOLOR=WHITE, " + & "BCOLOR=BLACK, ". + + 77 LIN PIC 99 COMP-5. + + 01 scr1 PIC X(75) + VALUE 'Enter "y" if the text below matches the colour ' + & 'of the background/text.'. + 01 scr2 PIC X(75) + VALUE 'Note: the black text is on white background/the ' + & 'white background has black'. + 01 scr3 PIC X(75) + VALUE 'text to make the text visible.' + & ' [This text *may* has "surrounding lines".]'. + 01 scr8 PIC X(75) + VALUE 'following lines should be identical but ' + & 'highlighted for the first line'. + 01 scr9 PIC X(75) + VALUE 'and blinking for the second one.'. + + 01 scrblack PIC X(08) VALUE 'Black'. + 01 scrblue PIC X(08) VALUE 'Blue'. + 01 scrgreen PIC X(08) VALUE 'Green'. + 01 scrcyan PIC X(08) VALUE 'Cyan'. + 01 scrred PIC X(08) VALUE 'Red'. + 01 scrmaggy PIC X(08) VALUE 'Magenta'. + 01 scryell PIC X(14) VALUE 'Brown/Yellow'. + 01 scrwhite PIC X(08) VALUE 'White'. + + PROCEDURE DIVISION. + testme. + MOVE 2 TO LIN + DISPLAY scr1 ( 1:1) AT LINE LIN COL 2 + CONTROL "LEFTLINE OVERLINE" + DISPLAY scr1 ( 2:) AT LINE LIN COL 2 + 1 + CONTROL "OVERLINE" + DISPLAY scr1 (75:) AT LINE LIN COL 2 + 75 + CONTROL "OVERLINE RIGHTLINE" + ADD 1 TO LIN + DISPLAY scr2 ( 1:1) AT LINE LIN COL 2 + CONTROL "LEFTLINE" + DISPLAY scr2 ( 2:) AT LINE LIN COL 2 + 1 + DISPLAY scr2 (75:) AT LINE LIN COL 2 + 75 + CONTROL "RIGHTLINE" + ADD 1 TO LIN + DISPLAY scr3 ( 1:1) AT LINE LIN COL 2 + CONTROL "LEFTLINE UNDERLINE" + DISPLAY scr3 ( 2:) AT LINE LIN COL 2 + 1 + CONTROL "UNDERLINE" + DISPLAY scr3 (75:) AT LINE LIN COL 2 + 75 + CONTROL "UNDERLINE RIGHTLINE" + * + ADD 2 TO LIN + PERFORM dspcol + MOVE "REVERSE," TO + CBLACK (40:), CBLUE (40:), CGREEN (40:), CCYAN (40:), + CRED (40:), CMAGENTA (40:), CYELLOW (40:), CWHITE (40:) + ADD 1 TO LIN + PERFORM dspcol + * + INSPECT CRED REPLACING ALL "=" BY " " + ADD 2 TO LIN + DISPLAY scr8 AT LINE LIN COL 2 + ADD 1 TO LIN + DISPLAY scr9 AT LINE LIN COL 2 + * + MOVE "HIGHLIGHT,NO REVERSE" TO + CBLACK (50:), CBLUE (50:), CGREEN (50:), CCYAN (50:), + CRED (50:), CMAGENTA (50:), CYELLOW (50:), CWHITE (50:) + ADD 1 TO LIN + PERFORM dspcol + MOVE "NO HIGH, BLINK" TO + CBLACK (60:), CBLUE (60:), CGREEN (60:), CCYAN (60:), + CRED (60:), CMAGENTA (60:), CYELLOW (60:), CWHITE (60:) + MOVE 12 TO LIN + PERFORM dspcol + * + ACCEPT success-flag AT 1801 UPDATE REQUIRED + + IF success AND COB-CRT-STATUS = 0 + GOBACK RETURNING 0 + ELSE + GOBACK RETURNING 1. + + dspcol. + DISPLAY scrblack LINE LIN COL 1, CONTROL CBLACK. + DISPLAY scrblue LINE LIN COL 10, CONTROL CBLUE. + DISPLAY scrgreen LINE LIN COL 19, CONTROL CGREEN. + DISPLAY scrcyan LINE LIN COL 28, CONTROL CCYAN. + DISPLAY scrred LINE LIN COL 37, CONTROL CRED. + DISPLAY scrmaggy LINE LIN COL 46, CONTROL CMAGENTA. + DISPLAY scryell LINE LIN COL 55, CONTROL CYELLOW. + DISPLAY scrwhite LINE LIN COL 70, CONTROL CWHITE. +]]) + +AT_CHECK([$COMPILE prog.cob], [0], [], []) +MANUAL_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) + +AT_CLEANUP + + +AT_SETUP([line draw characters via CONTROL GRAPHICS]) +AT_KEYWORDS([screen DISPLAY]) + +AT_SKIP_IF([test "$COB_HAS_CURSES" != "yes"]) + +AT_DATA([prog.cob], [[ + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 success-flag PIC X VALUE 'Y'. + 88 success VALUE 'Y', 'y'. + + 77 LIN-START PIC 99 COMP-5. + 77 LIN PIC 99 COMP-5. + + 01 scr1 PIC X(75) + VALUE 'Enter "y" if you see line draw characters. ' + & 'The first set (single/double)'. + 01 scr2 PIC X(75) + VALUE 'uses HIGHLIGHT, the second uses ' + & 'LOWLIGHT, BLINK and MAGENTA.'. + + 01 graphcontrol PIC X(50) VALUE 'HIGH, GRAPHICS'. + + PROCEDURE DIVISION. + testme. + MOVE 2 TO LIN + DISPLAY scr1 AT LINE LIN COL 2 + ADD 1 TO LIN + DISPLAY scr2 AT LINE LIN COL 2 + * + MOVE 5 TO LIN-START + PERFORM dspcol + MOVE 12 TO LIN-START + MOVE "LOW BLINK FCOLOR=MAGENTA GRAPHICS" TO graphcontrol + PERFORM dspcol + * + ACCEPT success-flag AT 1801 UPDATE REQUIRED + + IF success AND COB-CRT-STATUS = 0 + GOBACK RETURNING 0 + ELSE + GOBACK RETURNING 1. + + dspcol. + * Single-line graphics + MOVE LIN-START TO LIN + DISPLAY "lqqqqwqqqqk" LINE LIN COL 05, CONTROL graphcontrol. + ADD 1 TO LIN + DISPLAY "x x x" LINE LIN COL 05, CONTROL graphcontrol. + ADD 1 TO LIN + DISPLAY "tqqqqnqqqqu" LINE LIN COL 05, CONTROL graphcontrol. + ADD 1 TO LIN + DISPLAY "x x x" LINE LIN COL 05, CONTROL graphcontrol. + ADD 1 TO LIN + DISPLAY "mqqqqvqqqqj" LINE LIN COL 05, CONTROL graphcontrol. + ADD 1 TO LIN + * Double-line graphics + MOVE LIN-START TO LIN + DISPLAY "LQQQQWQQQQK" LINE LIN COL 20, CONTROL graphcontrol. + ADD 1 TO LIN + DISPLAY "X X X" LINE LIN COL 20, CONTROL graphcontrol. + ADD 1 TO LIN + DISPLAY "TQQQQNQQQQU" LINE LIN COL 20, CONTROL graphcontrol. + ADD 1 TO LIN + DISPLAY "X X X" LINE LIN COL 20, CONTROL graphcontrol. + ADD 1 TO LIN + DISPLAY "MQQQQVQQQQJ" LINE LIN COL 20, CONTROL graphcontrol. +]]) + +AT_CHECK([$COMPILE prog.cob], [0], [], []) +MANUAL_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) + +AT_CLEANUP + + +AT_SETUP([BEEP]) +AT_KEYWORDS([BELL FLASH]) + +AT_SKIP_IF([test "$COB_HAS_CURSES" != "yes"]) + +AT_DATA([prog.cob], [ + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 success-flag PIC X. + 88 success VALUE 'Y', 'y'. + + SCREEN SECTION. + 01 scr. + 03 BELL. + 03 VALUE 'Enter "y" if you heard a beep:'. + 03 success-field PIC X, COL + 2, REQUIRED, TO success-flag + FROM 'Y'. + 01 scr2. + 03 LINE 4 VALUE 'system beep may be turned off ' & + 'on this system.'. + 03 LINE 5 VALUE 'Retesting with COB_BELL=FLASH...'. + 03 LINE + 2, + VALUE 'Enter "y" if you''ve seen your terminal flash'. + 03 success-field PIC X, COL + 2, REQUIRED, TO success-flag + FROM 'Y'. + + PROCEDURE DIVISION. + DISPLAY scr + ACCEPT scr + + IF success AND COB-CRT-STATUS = 0 + GOBACK RETURNING 0 + END-IF + + SET ENVIRONMENT 'COB_BELL' TO 'FLASH' + CALL 'C$SLEEP' USING '1' + + DISPLAY scr2 + DISPLAY ALL X'07' UPON CRT + ACCEPT scr2 + + IF success AND COB-CRT-STATUS = 0 + GOBACK RETURNING 0 + ELSE + GOBACK RETURNING 1 + END-IF + . +]) + +AT_CHECK([$COMPILE prog.cob], [0], [], []) +MANUAL_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) + +AT_CLEANUP + + +AT_SETUP([BLANK LINE]) +AT_KEYWORDS([screen]) + +AT_SKIP_IF([test "$COB_HAS_CURSES" != "yes"]) + +AT_DATA([prog.cob], [ + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 success-flag PIC X VALUE 'Y'. + 88 success VALUE 'Y', 'y'. + + SCREEN SECTION. + 01 scr-1. + 03 LINE 3 VALUE 'Lorem ipsum dolor sit amet, consectetur ad' + & 'ipiscing elit. Curabitur dapibus dui'. + 03 LINE 4 VALUE 'vitae augue lobortis, non tempor diam tris' + & 'tique. Donec dignissim ex velit, ut'. + 03 LINE 5 VALUE 'efficitur tellus pharetra at. Curabitur at' + & ' condimentum nunc, nec accumsan'. + 03 LINE 6 VALUE 'nulla. Nulla at feugiat elit, eget condime' + & 'ntum justo. Nam lorem lectus,'. + 03 LINE 7 VALUE 'imperdiet sit amet odio eu, eleifend conse' + & 'ctetur ligula. Duis diam felis, porta'. + 03 LINE 8 VALUE 'id diam id, ultrices finibus augue. Mauris' + & ' imperdiet, dolor sed sodales porta,'. + 03 LINE 9 VALUE 'justo nunc consequat nulla, iaculis venena' + & 'tis lorem libero sit amet'. + 03 LINE 10 VALUE 'magna. Nullam pulvinar nullam.'. + 03 success-field LINE + 2, PIC X, REQUIRED, + USING success-flag. + + 01 scr-2. + 03 LINE 6 COL 8 VALUE 'foo' BLANK LINE, HIGHLIGHT. + 03 LINE 1 VALUE 'Enter "y" if foo is the only word on one' + & ' line.'. + + PROCEDURE DIVISION. + DISPLAY scr-1 + DISPLAY scr-2 + ACCEPT success-field + + IF success AND COB-CRT-STATUS = 0 + GOBACK RETURNING 0 + ELSE + GOBACK RETURNING 1 + END-IF + . +]) + +AT_CHECK([$COMPILE prog.cob], [0], [], []) +MANUAL_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) + +AT_CLEANUP + + +AT_SETUP([BLANK SCREEN]) +AT_KEYWORDS([screen]) + +AT_SKIP_IF([test "$COB_HAS_CURSES" != "yes"]) + +AT_DATA([prog.cob], [ + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 success-flag PIC X VALUE 'Y'. + 88 success VALUE 'Y', 'y'. + + SCREEN SECTION. + 01 scr-1. + 03 LINE 3 VALUE 'Lorem ipsum dolor sit amet, consectetur ad' + & 'ipiscing elit. Curabitur dapibus dui'. + 03 LINE 4 VALUE 'vitae augue lobortis, non tempor diam tris' + & 'tique. Donec dignissim ex velit, ut'. + 03 LINE 5 VALUE 'efficitur tellus pharetra at. Curabitur at' + & ' condimentum nunc, nec accumsan'. + 03 LINE 6 VALUE 'nulla. Nulla at feugiat elit, eget condime' + & 'ntum justo. Nam lorem lectus,'. + 03 LINE 7 VALUE 'imperdiet sit amet odio eu, eleifend conse' + & 'ctetur ligula. Duis diam felis, porta'. + 03 LINE 8 VALUE 'id diam id, ultrices finibus augue. Mauris' + & ' imperdiet, dolor sed sodales porta,'. + 03 LINE 9 VALUE 'justo nunc consequat nulla, iaculis venena' + & 'tis lorem libero sit amet'. + 03 LINE 10 VALUE 'magna. Nullam pulvinar nullam.'. + 03 success-field LINE + 2, PIC X, REQUIRED, + USING success-flag. + + 01 scr-2. + 03 LINE 6 COL 8 VALUE 'foo' BLANK SCREEN, HIGHLIGHT. + 03 LINE 1 VALUE 'Enter "y" if foo is the only word below.'. + + PROCEDURE DIVISION. + DISPLAY scr-1 + DISPLAY scr-2 + ACCEPT success-field + + IF success AND COB-CRT-STATUS = 0 + GOBACK RETURNING 0 + ELSE + GOBACK RETURNING 1 + END-IF + . +]) + +AT_CHECK([$COMPILE prog.cob], [0], [], []) +MANUAL_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) + +AT_CLEANUP + + +AT_SETUP([BLANK ignored in ACCEPT]) +AT_KEYWORDS([screen]) + +AT_SKIP_IF([test "$COB_HAS_CURSES" != "yes"]) + +AT_DATA([prog.cob], [ + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 success-flag PIC X VALUE 'Y'. + 88 success VALUE 'Y', 'y'. + + SCREEN SECTION. + 01 scr. + 03 LINE 1 VALUE 'Enter "y" if you can see lorem ipsum ' + & 'filler text.'. + 03 LINE 3 COL 3 VALUE 'Lorem ipsum dolor sit amet,' + & ' consectetur ad ipiscing elit.'. + + 01 success-scr. + 03 LINE 3, BLANK LINE, PIC X, REQUIRED, USING success-flag. + + PROCEDURE DIVISION. + DISPLAY scr + ACCEPT success-scr + + IF success AND COB-CRT-STATUS = 0 + GOBACK RETURNING 0 + ELSE + GOBACK RETURNING 1 + END-IF + . +]) + +AT_CHECK([$COMPILE prog.cob], [0], [], []) +MANUAL_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) + +AT_CLEANUP + + +AT_SETUP([BLINK]) +AT_KEYWORDS([screen]) + +AT_SKIP_IF([test "$COB_HAS_CURSES" != "yes"]) + +AT_DATA([prog.cob], [ + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 success-flag PIC X VALUE 'Y'. + 88 success VALUE 'Y', 'y'. + + SCREEN SECTION. + 01 scr. + 03 PIC X(80) + VALUE 'Enter "y" if the string below is blinking:'. + 03 LINE + 1, PIC X(10) VALUE 'Blink' BLINK. + 03 success-field LINE + 2, PIC X, REQUIRED, + USING success-flag. + + PROCEDURE DIVISION. + DISPLAY scr + ACCEPT scr + + IF success AND COB-CRT-STATUS = 0 + GOBACK RETURNING 0 + ELSE + GOBACK RETURNING 1 + END-IF + . +]) + +AT_CHECK([$COMPILE prog.cob], [0], [], []) +MANUAL_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) + +AT_CLEANUP + + +AT_SETUP([ERASE EOS]) +AT_KEYWORDS([screen]) + +AT_SKIP_IF([test "$COB_HAS_CURSES" != "yes"]) + +AT_DATA([prog.cob], [ + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 success-flag PIC X VALUE 'Y'. + 88 success VALUE 'Y', 'y'. + + SCREEN SECTION. + 01 scr-1. + 03 LINE 1 VALUE 'Enter "y" if all the text after foo in the' + & ' screen has been erased.'. + 03 LINE 3 VALUE 'Lorem ipsum dolor sit amet, consectetur ad' + & 'ipiscing elit. Curabitur dapibus dui'. + 03 LINE 4 VALUE 'vitae augue lobortis, non tempor diam tris' + & 'tique. Donec dignissim ex velit, ut'. + 03 LINE 5 VALUE 'efficitur tellus pharetra at. Curabitur at' + & ' condimentum nunc, nec accumsan'. + 03 LINE 6 VALUE 'nulla. Nulla at feugiat elit, eget condime' + & 'ntum justo. Nam lorem lectus,'. + 03 LINE 7 VALUE 'imperdiet sit amet odio eu, eleifend conse' + & 'ctetur ligula. Duis diam felis, porta'. + 03 LINE 8 VALUE 'id diam id, ultrices finibus augue. Mauris' + & ' imperdiet, dolor sed sodales porta,'. + 03 LINE 9 VALUE 'justo nunc consequat nulla, iaculis venena' + & 'tis lorem libero sit amet'. + 03 LINE 10 VALUE 'magna. Nullam pulvinar nullam.'. + 03 success-field LINE + 2, PIC X, REQUIRED, + USING success-flag. + + 01 scr-2. + 03 LINE 6 COL 8 VALUE 'foo' ERASE EOS, HIGHLIGHT. + + PROCEDURE DIVISION. + DISPLAY scr-1 + DISPLAY scr-2 + ACCEPT success-field + + IF success AND COB-CRT-STATUS = 0 + GOBACK RETURNING 0 + ELSE + GOBACK RETURNING 1 + END-IF + . +]) + +AT_CHECK([$COMPILE prog.cob], [0], [], []) +MANUAL_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) + +AT_CLEANUP + + +AT_SETUP([ERASE EOL]) +AT_KEYWORDS([screen]) + +AT_SKIP_IF([test "$COB_HAS_CURSES" != "yes"]) + +AT_DATA([prog.cob], [ + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 success-flag PIC X VALUE 'Y'. + 88 success VALUE 'Y', 'y'. + + SCREEN SECTION. + 01 scr-1. + 03 LINE 1 VALUE 'Enter "y" if all the text after foo on ' + & 'that line alone has been erased.'. + 03 LINE 3 VALUE 'Lorem ipsum dolor sit amet, consectetur ad' + & 'ipiscing elit. Curabitur dapibus dui'. + 03 LINE 4 VALUE 'vitae augue lobortis, non tempor diam tris' + & 'tique. Donec dignissim ex velit, ut'. + 03 LINE 5 VALUE 'efficitur tellus pharetra at. Curabitur at' + & ' condimentum nunc, nec accumsan'. + 03 LINE 6 VALUE 'nulla. Nulla at feugiat elit, eget condime' + & 'ntum justo. Nam lorem lectus,'. + 03 LINE 7 VALUE 'imperdiet sit amet odio eu, eleifend conse' + & 'ctetur ligula. Duis diam felis, porta'. + 03 LINE 8 VALUE 'id diam id, ultrices finibus augue. Mauris' + & ' imperdiet, dolor sed sodales porta,'. + 03 LINE 9 VALUE 'justo nunc consequat nulla, iaculis venena' + & 'tis lorem libero sit amet'. + 03 LINE 10 VALUE 'magna. Nullam pulvinar nullam.'. + 03 success-field LINE + 2, PIC X, REQUIRED, + USING success-flag. + + 01 scr-2. + 03 LINE 6 COL 8 VALUE 'foo' ERASE EOL, HIGHLIGHT. + + PROCEDURE DIVISION. + DISPLAY scr-1 + DISPLAY scr-2 + ACCEPT success-field + + IF success AND COB-CRT-STATUS = 0 + GOBACK RETURNING 0 + ELSE + GOBACK RETURNING 1 + END-IF + . +]) + +AT_CHECK([$COMPILE prog.cob], [0], [], []) +MANUAL_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) + +AT_CLEANUP + + +AT_SETUP([ERASE ignored in ACCEPT]) +AT_KEYWORDS([EOS]) + +AT_SKIP_IF([test "$COB_HAS_CURSES" != "yes"]) + +AT_DATA([prog.cob], [ + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 success-flag PIC X VALUE 'Y'. + 88 success VALUE 'Y', 'y'. + + SCREEN SECTION. + 01 scr. + 03 LINE 1 VALUE 'Enter "y" if you can see lorem ipsum ' + & 'filler text.'. + 03 LINE 3 VALUE 'Lorem ipsum dolor sit amet, consectetur ad' + & 'ipiscing elit. Curabitur dapibus dui'. + 03 LINE 4 VALUE 'vitae augue lobortis, non tempor diam tris' + & 'tique. Donec dignissim ex velit, ut'. + 03 LINE 5 VALUE 'efficitur tellus pharetra at. Curabitur at' + & ' condimentum nunc, nec accumsan'. + 03 LINE 6 VALUE 'nulla. Nulla at feugiat elit, eget condime' + & 'ntum justo. Nam lorem lectus,'. + 03 LINE 7 VALUE 'imperdiet sit amet odio eu, eleifend conse' + & 'ctetur ligula. Duis diam felis, porta'. + 03 LINE 8 VALUE 'id diam id, ultrices finibus augue. Mauris' + & ' imperdiet, dolor sed sodales porta,'. + 03 LINE 9 VALUE 'justo nunc consequat nulla, iaculis venena' + & 'tis lorem libero sit amet'. + 03 LINE 10 VALUE 'magna. Nullam pulvinar nullam.'. + 03 LINE 3 ERASE EOS. + 03 success-field LINE 12, PIC X, REQUIRED, + USING success-flag. + + PROCEDURE DIVISION. + DISPLAY scr + ACCEPT scr + + IF success AND COB-CRT-STATUS = 0 + GOBACK RETURNING 0 + ELSE + GOBACK RETURNING 1 + END-IF + . +]) + +AT_CHECK([$COMPILE prog.cob], [0], [], []) +MANUAL_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) + +AT_CLEANUP + + +AT_SETUP([FULL and REQUIRED]) +AT_KEYWORDS([screen]) + +AT_SKIP_IF([test "$COB_HAS_CURSES" != "yes"]) + +AT_DATA([prog.cob], [ + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 dummy PIC X(10). + 01 success-flag PIC X. + 88 success VALUE 'Y', 'y'. + + SCREEN SECTION. + 01 scr. + 03 PIC X(80) + VALUE 'Enter "y" if you cannot continue without filling ' + & 'all of the below field:'. + 03 LINE + 1, PIC X(10), FULL, REQUIRED, TO dummy. + *> no initial value for success as we request input + 03 success-field LINE + 2, PIC X, REQUIRED, TO success-flag. + + PROCEDURE DIVISION. + DISPLAY scr + ACCEPT scr + + IF success AND COB-CRT-STATUS = 0 + GOBACK RETURNING 0 + ELSE + GOBACK RETURNING 1 + END-IF + . +]) + +AT_CHECK([$COMPILE prog.cob], [0], [], []) +MANUAL_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) + +AT_CLEANUP + + +AT_SETUP([HIGHLIGHT]) +AT_KEYWORDS([screen]) + +AT_SKIP_IF([test "$COB_HAS_CURSES" != "yes"]) + +AT_DATA([prog.cob], [ + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 success-flag PIC X VALUE 'Y'. + 88 success VALUE 'Y', 'y'. + + SCREEN SECTION. + 01 scr. + 03 PIC X(80) + VALUE 'Enter "y" if the text below is bright ' + & '(highlighted):'. + 03 LINE + 1, PIC X(10) VALUE 'Highlight' HIGHLIGHT. + 03 success-field LINE + 2, PIC X, REQUIRED, + USING success-flag. + + PROCEDURE DIVISION. + DISPLAY scr + ACCEPT scr + + IF success AND COB-CRT-STATUS = 0 + GOBACK RETURNING 0 + ELSE + GOBACK RETURNING 1 + END-IF + . +]) + +AT_CHECK([$COMPILE prog.cob], [0], [], []) +MANUAL_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) + +AT_CLEANUP + + +AT_SETUP([INITIAL]) +AT_KEYWORDS([screen]) + +AT_SKIP_IF([test "$COB_HAS_CURSES" != "yes"]) + +AT_DATA([prog.cob], [ + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 dummy-1 PIC X(10). + 01 dummy-2 PIC X(10). + 01 dummy-3 PIC X(10). + + 01 success-flag PIC X VALUE 'Y'. + 88 success VALUE 'Y', 'y'. + + SCREEN SECTION. + 01 scr. + 03 PIC X(80) VALUE 'Enter "y" if the cursor is initially '- + 'located at the start of the rightmost'. + 03 LINE + 1, PIC X(80) VALUE 'field.'. + 03 LINE + 2, PIC X(10) TO dummy-1. + 03 COL + 2, PIC X(10) TO dummy-2. + 03 COL + 2, PIC X(10) TO dummy-3, INITIAL. + 03 success-field LINE + 2, PIC X, REQUIRED, + USING success-flag. + + PROCEDURE DIVISION. + DISPLAY scr + ACCEPT scr + + IF success AND COB-CRT-STATUS = 0 + GOBACK RETURNING 0 + ELSE + GOBACK RETURNING 1 + END-IF + . +]) + +AT_CHECK([$COMPILE prog.cob], [0], [], []) +MANUAL_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) + +AT_CLEANUP + + +AT_SETUP([LEFTLINE]) +AT_KEYWORDS([GRID]) + +AT_SKIP_IF([test "$COB_HAS_CURSES" != "yes"]) + +# Currently not implemented +AT_XFAIL_IF([true]) + +AT_DATA([prog.cob], [ + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 success-flag PIC X VALUE 'Y'. + 88 success VALUE 'Y', 'y'. + + SCREEN SECTION. + 01 scr. + 03 PIC X(80) + VALUE 'Enter "y" if the string has a vertical line to ' + & 'its left:'. + 03 LINE + 1, COL 2, PIC X(10) VALUE 'Leftline' LEFTLINE. + 03 success-field LINE + 2, PIC X, REQUIRED, + USING success-flag. + + PROCEDURE DIVISION. + DISPLAY scr + ACCEPT scr + + IF success AND COB-CRT-STATUS = 0 + GOBACK RETURNING 0 + ELSE + GOBACK RETURNING 1 + END-IF + . +]) + +AT_CHECK([$COMPILE prog.cob], [0], [], []) +MANUAL_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) + +AT_CLEANUP + + +AT_SETUP([LOWLIGHT]) +AT_KEYWORDS([screen]) + +AT_SKIP_IF([test "$COB_HAS_CURSES" != "yes"]) + +AT_DATA([prog.cob], [ + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 success-flag PIC X VALUE 'Y'. + 88 success VALUE 'Y', 'y'. + + SCREEN SECTION. + 01 scr. + 03 PIC X(80) + VALUE 'Enter "y" if the string below is dim (lowlight):'. + 03 LINE + 1, PIC X(10) VALUE 'Lowlight' LOWLIGHT. + 03 success-field LINE + 2, PIC X, REQUIRED, + USING success-flag. + + PROCEDURE DIVISION. + DISPLAY scr + ACCEPT scr + + IF success AND COB-CRT-STATUS = 0 + GOBACK RETURNING 0 + ELSE + GOBACK RETURNING 1 + END-IF + . +]) + +AT_CHECK([$COMPILE prog.cob], [0], [], []) +MANUAL_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) + +AT_CLEANUP + + +AT_SETUP([OVERLINE]) +AT_KEYWORDS([screen]) + +AT_SKIP_IF([test "$COB_HAS_CURSES" != "yes"]) + +# Currently not implemented +AT_XFAIL_IF([true]) + +AT_DATA([prog.cob], [ + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 success-flag PIC X VALUE 'Y'. + 88 success VALUE 'Y', 'y'. + + SCREEN SECTION. + 01 scr. + 03 PIC X(80) + VALUE 'Enter "y" if the string below is overlined:'. + 03 LINE + 1, PIC X(10) VALUE 'Overline' OVERLINE. + 03 success-field LINE + 2, PIC X, REQUIRED, + USING success-flag. + + PROCEDURE DIVISION. + DISPLAY scr + ACCEPT scr + + IF success AND COB-CRT-STATUS = 0 + GOBACK RETURNING 0 + ELSE + GOBACK RETURNING 1 + END-IF + . +]) + +AT_CHECK([$COMPILE prog.cob], [0], [], []) +MANUAL_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) + +AT_CLEANUP + + +AT_SETUP([REVERSE-VIDEO]) +AT_KEYWORDS([screen]) + +AT_SKIP_IF([test "$COB_HAS_CURSES" != "yes"]) + +AT_DATA([prog.cob], [ + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 success-flag PIC X VALUE 'Y'. + 88 success VALUE 'Y', 'y'. + + SCREEN SECTION. + 01 scr. + 03 PIC X(80) + VALUE 'Enter "y" if the background and foreground ' + & 'colours of the string below have'. + 03 LINE + 1, PIC X(80) VALUE 'swapped:'. + 03 LINE + 1, PIC X(20) VALUE 'Reversed colours' + REVERSE-VIDEO. + 03 success-field LINE + 2, PIC X USING success-flag. + + PROCEDURE DIVISION. + DISPLAY scr + ACCEPT scr + + IF success AND COB-CRT-STATUS = 0 + GOBACK RETURNING 0 + ELSE + GOBACK RETURNING 1 + END-IF + . +]) + +AT_CHECK([$COMPILE prog.cob], [0], [], []) +MANUAL_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) + +AT_CLEANUP + + +AT_SETUP([SECURE]) +AT_KEYWORDS([PASSWORD]) + +AT_SKIP_IF([test "$COB_HAS_CURSES" != "yes"]) + +AT_DATA([prog.cob], [ + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 dummy PIC X(10). + 01 success-flag PIC X VALUE 'Y'. + 88 success VALUE 'Y', 'y'. + + SCREEN SECTION. + 01 scr. + 03 PIC X(80) + VALUE 'Enter "y" if text in the field below is replaced ' + & 'with asterisks:'. + 03 LINE + 1, PIC X(10) SECURE TO dummy, PROMPT CHARACTER + "-". + 03 success-field LINE + 2, PIC X, REQUIRED, + USING success-flag. + + PROCEDURE DIVISION. + DISPLAY scr + ACCEPT scr + + IF success AND COB-CRT-STATUS = 0 + GOBACK RETURNING 0 + ELSE + GOBACK RETURNING 1 + END-IF + . +]) + +AT_CHECK([$COMPILE prog.cob], [0], [], []) +MANUAL_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) + +AT_CLEANUP + + +AT_SETUP([SIZE with items]) +AT_KEYWORDS([PROTECTED extensions]) + +AT_SKIP_IF([test "$COB_HAS_CURSES" != "yes"]) + +AT_DATA([prog.cob], [ + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 success-flag PIC X VALUE 'Y'. + 88 success VALUE 'Y', 'y'. + + 01 num-1 PIC 9(5) VALUE 12345. + 01 num-2 PIC X(10) VALUE '12345'. + 01 num-3 PIC 9(4) VALUE 1234. + + 01 four PIC 9 VALUE 4. + + PROCEDURE DIVISION. + DISPLAY 'Enter "y" if you see exactly four rows of 1234, all' + & ' aligned.' LINE 1 + + DISPLAY num-1 LINE 3 COL 3, SIZE 4; + num-2 LINE 4 COL 3, SIZE four; + num-3 LINE 5 COL 3, SIZE 8; + '1234' LINE 6 COL 3, SIZE ZERO + + ACCEPT success-flag LINE 8, REQUIRED UPDATE + + IF success AND COB-CRT-STATUS = 0 + GOBACK RETURNING 0 + ELSE + GOBACK RETURNING 1 + END-IF + . +]) + +AT_CHECK([$COMPILE prog.cob], [0], [], []) +MANUAL_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) + +AT_CLEANUP + + +AT_SETUP([SIZE with figurative constants]) +AT_KEYWORDS([PROTECTED extensions]) + +AT_SKIP_IF([test "$COB_HAS_CURSES" != "yes"]) + +AT_DATA([prog.cob], [ + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 success-flag PIC X VALUE 'Y'. + 88 success VALUE 'Y', 'y'. + + PROCEDURE DIVISION. + DISPLAY 'Enter "y" if you see exactly three rows of quotes, ' + & 'zeroes and ''abc'',', LINE 1 + DISPLAY '8 characters long, all aligned.', LINE 2 + + DISPLAY QUOTES LINE 4 COL 3, SIZE 8; + ZEROES LINE 5 COL 3, SIZE 8; + ALL 'abc' LINE 6 COL 3, SIZE 8 + + DISPLAY '123456789' LINE 7 COL 3 + DISPLAY SPACE LINE 7 COL 3, SIZE 9 + + ACCEPT success-flag LINE 8, REQUIRED UPDATE + + IF success AND COB-CRT-STATUS = 0 + GOBACK RETURNING 0 + ELSE + GOBACK RETURNING 1 + END-IF + . +]) + +AT_CHECK([$COMPILE prog.cob], [0], [], []) +MANUAL_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) + +AT_CLEANUP + + +AT_SETUP([UPDATE]) +AT_KEYWORDS([extensions]) + +AT_SKIP_IF([test "$COB_HAS_CURSES" != "yes"]) + +AT_DATA([prog.cob], [ + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 n-str PIC X(12) VALUE SPACES. + 01 success-flag PIC X. + 88 success VALUE 'Y', 'y'. + + SCREEN SECTION. + 01 scr. + 03 VALUE 'Enter "y" if the entry field below is filled with' + & ' N''s'. + 03 n-field, LINE + 1, PIC X(12) USING n-str. + 03 success-field, LINE + 2, PIC X, REQUIRED, + TO success-flag, FROM 'Y'. + + PROCEDURE DIVISION. + DISPLAY scr + MOVE ALL 'N' TO n-str + ACCEPT scr + + IF success AND COB-CRT-STATUS = 0 + GOBACK RETURNING 0 + ELSE + GOBACK RETURNING 1 + END-IF + . +]) + +AT_CHECK([$COMPILE -fno-accept-update prog.cob], [0], [], []) +MANUAL_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) + +AT_CLEANUP + + +AT_SETUP([UNDERLINE]) +AT_KEYWORDS([screen]) + +AT_SKIP_IF([test "$COB_HAS_CURSES" != "yes"]) + +AT_DATA([prog.cob], [ + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 success-flag PIC X VALUE 'Y'. + 88 success VALUE 'Y', 'y'. + + SCREEN SECTION. + 01 scr. + 03 PIC X(80) + VALUE 'Enter "y" if the string below is underlined:'. + 03 LINE + 1, PIC X(10) VALUE 'Underline' UNDERLINE. + 03 success-field LINE + 2, PIC X, REQUIRED, + USING success-flag. + + PROCEDURE DIVISION. + DISPLAY scr + ACCEPT scr + + IF success AND COB-CRT-STATUS = 0 + GOBACK RETURNING 0 + ELSE + GOBACK RETURNING 1 + END-IF + . +]) + +AT_CHECK([$COMPILE prog.cob], [0], [], []) +MANUAL_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) + +AT_CLEANUP + + +AT_SETUP([SPECIAL-NAMES CURSOR phrase 6-digit with field]) +AT_KEYWORDS([position ACCEPT]) + +AT_SKIP_IF([test "$COB_HAS_CURSES" != "yes"]) + +AT_DATA([prog.cob], [ + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + ENVIRONMENT DIVISION. + CONFIGURATION SECTION. + SPECIAL-NAMES. + CURSOR IS cur-pos. + DATA DIVISION. + WORKING-STORAGE SECTION. + 77 cur-pos pic 9(06). + 01 success-flag PIC X VALUE 'Y'. + 88 success VALUE 'Y', 'y'. + 01 ws-x-20 PIC X(20). + PROCEDURE DIVISION. + testme. + set environment 'COB_SCREEN_EXCEPTIONS' to 'TRUE' + set environment 'COB_SCREEN_ESC' to 'TRUE' + + DISPLAY "If the cursor below is positioned at the 'C'" + LINE 1 COLUMN 1. + DISPLAY "(third column) below, then position it at the" + LINE 2 COLUMN 1. + DISPLAY "'E' (fifth column) and press ENTER." + LINE 3 COLUMN 1. + + MOVE "ABCDEFG " TO WS-X-20. + MOVE 005003 TO cur-pos. + ACCEPT WS-X-20 + LINE 5 COLUMN 1 + WITH + AUTO-SKIP + SIZE 10 + UPDATE. + + IF cur-pos = 005005 AND COB-CRT-STATUS = 0 + GOBACK RETURNING 0 + ELSE + GOBACK RETURNING 1 + END-IF + . +]) + +AT_CHECK([$COMPILE prog.cob], [0], [], []) +MANUAL_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) + +AT_CLEANUP + + +AT_SETUP([SPECIAL-NAMES CURSOR phrase 4-digit with field]) +AT_KEYWORDS([position ACCEPT]) + +AT_SKIP_IF([test "$COB_HAS_CURSES" != "yes"]) + +AT_DATA([prog.cob], [ + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + ENVIRONMENT DIVISION. + CONFIGURATION SECTION. + SPECIAL-NAMES. + CURSOR IS cur-pos. + DATA DIVISION. + WORKING-STORAGE SECTION. + 77 cur-pos pic 9(04). + 01 success-flag PIC X VALUE 'Y'. + 88 success VALUE 'Y', 'y'. + 01 ws-x-20 PIC X(20). + PROCEDURE DIVISION. + testme. + set environment 'COB_SCREEN_EXCEPTIONS' to 'TRUE' + set environment 'COB_SCREEN_ESC' to 'TRUE' + + DISPLAY "If the cursor below is positioned at the 'C'" + LINE 1 COLUMN 1. + DISPLAY "(third column) below, then position it at the" + LINE 2 COLUMN 1. + DISPLAY "'E' (fifth column) and press ENTER." + LINE 3 COLUMN 1. + + MOVE "ABCDEFG " TO WS-X-20. + MOVE 0503 TO cur-pos. + ACCEPT WS-X-20 + LINE 5 COLUMN 1 + WITH + AUTO-SKIP + SIZE 10 + UPDATE. + + IF cur-pos = 0505 AND COB-CRT-STATUS = 0 + GOBACK RETURNING 0 + ELSE + GOBACK RETURNING 1 + END-IF + . +]) + +AT_CHECK([$COMPILE prog.cob], [0], [], []) +MANUAL_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) + +AT_CLEANUP + + +AT_SETUP([ACCEPT field WITH CURSOR data-item]) +AT_KEYWORDS([position]) + +AT_SKIP_IF([test "$COB_HAS_CURSES" != "yes"]) + +AT_DATA([prog.cob], [ + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 77 cur-pos pic 9(04). + 01 success-flag PIC X VALUE 'Y'. + 88 success VALUE 'Y', 'y'. + 01 ws-x-20 PIC X(20). + PROCEDURE DIVISION. + testme. + set environment 'COB_SCREEN_EXCEPTIONS' to 'TRUE' + set environment 'COB_SCREEN_ESC' to 'TRUE' + + DISPLAY "If the cursor below is positioned at the 'C'" + LINE 1 COLUMN 1. + DISPLAY "(third column in field) below, then position it at" + LINE 2 COLUMN 1. + DISPLAY "the 'E' (fifth column) and press ENTER." + LINE 3 COLUMN 1. + + MOVE "ABCDEFG " TO WS-X-20. + MOVE 0003 TO cur-pos. + ACCEPT WS-X-20 + LINE 5 COLUMN 3 + WITH + AUTO-SKIP + SIZE 10 + CURSOR cur-pos + UPDATE. + + IF cur-pos = 0005 AND COB-CRT-STATUS = 0 + GOBACK RETURNING 0 + ELSE + GOBACK RETURNING 1 + END-IF + . +]) + +AT_CHECK([$COMPILE prog.cob], [0], [], []) +MANUAL_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) + +AT_CLEANUP + + +AT_SETUP([ACCEPT field WITH CURSOR size overflow]) +AT_KEYWORDS([position]) + +AT_SKIP_IF([test "$COB_HAS_CURSES" != "yes"]) + +AT_DATA([prog.cob], [ + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 77 cur-pos pic 9(04). + 01 success-flag PIC X VALUE 'Y'. + 88 success VALUE 'Y', 'y'. + 01 ws-x-20 PIC X(10). + PROCEDURE DIVISION. + testme. + set environment 'COB_SCREEN_EXCEPTIONS' to 'TRUE' + set environment 'COB_SCREEN_ESC' to 'TRUE' + + DISPLAY "If the cursor below is positioned at the last" + LINE 1 COLUMN 1. + DISPLAY "column in the field below, then position it at" + LINE 2 COLUMN 1. + DISPLAY "the 'C' (third column) and press ENTER." + LINE 3 COLUMN 1. + + MOVE "ABCDEFGHIJ" TO WS-X-20. + MOVE 0012 TO cur-pos. + ACCEPT WS-X-20 + LINE 5 COLUMN 3 + WITH + AUTO-SKIP + SIZE 10 + CURSOR cur-pos + UPDATE. + + IF cur-pos = 0003 AND COB-CRT-STATUS = 0 + GOBACK RETURNING 0 + ELSE + GOBACK RETURNING 1 + END-IF + . +]) + +AT_CHECK([$COMPILE prog.cob], [0], [], []) +MANUAL_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) + +AT_CLEANUP + + +AT_SETUP([ACCEPT field WITH CURSOR data overflow I]) +AT_KEYWORDS([position]) + +AT_SKIP_IF([test "$COB_HAS_CURSES" != "yes"]) + +AT_DATA([prog.cob], [ + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 77 cur-pos pic 9(04). + 01 success-flag PIC X VALUE 'Y'. + 88 success VALUE 'Y', 'y'. + 01 ws-x-20 PIC X(20). + PROCEDURE DIVISION. + testme. + set environment 'COB_SCREEN_EXCEPTIONS' to 'TRUE' + set environment 'COB_SCREEN_ESC' to 'TRUE' + + DISPLAY "If the cursor below is positioned at the 'E'" + LINE 1 COLUMN 1. + DISPLAY "(fifth column in field) below, then position it at" + LINE 2 COLUMN 1. + DISPLAY "the 'C' (third column) and press ENTER." + LINE 3 COLUMN 1. + + MOVE "ABCDE " TO WS-X-20. + MOVE 0008 TO cur-pos. + ACCEPT WS-X-20 + LINE 5 COLUMN 3 + WITH + AUTO-SKIP + SIZE 10 + CURSOR cur-pos + UPDATE. + + IF cur-pos = 0003 AND COB-CRT-STATUS = 0 + GOBACK RETURNING 0 + ELSE + GOBACK RETURNING 1 + END-IF + . +]) + +AT_CHECK([$COMPILE prog.cob], [0], [], []) +MANUAL_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) + +AT_CLEANUP + + +AT_SETUP([ACCEPT field WITH CURSOR data overflow II]) +AT_KEYWORDS([position UNDERLINE]) + +AT_SKIP_IF([test "$COB_HAS_CURSES" != "yes"]) + +AT_DATA([prog.cob], [ + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 77 cur-pos pic 9(04). + 01 success-flag PIC X VALUE 'Y'. + 88 success VALUE 'Y', 'y'. + 01 ws-x-20 PIC X(20). + PROCEDURE DIVISION. + testme. + set environment 'COB_SCREEN_EXCEPTIONS' to 'TRUE' + set environment 'COB_SCREEN_ESC' to 'TRUE' + + DISPLAY "If the cursor below is positioned at the first" + LINE 1 COLUMN 1. + DISPLAY "column in the field below and it is empty, then" + LINE 2 COLUMN 1. + DISPLAY "enter 'AB', position after the 'B' and press ENTER." + LINE 3 COLUMN 1. + + MOVE "ABCDE " TO WS-X-20. + MOVE 0008 TO cur-pos. + ACCEPT WS-X-20 + LINE 5 COLUMN 3 + WITH + SIZE 10 + UNDERLINE + CURSOR cur-pos. + + IF cur-pos = 0003 AND COB-CRT-STATUS = 0 + GOBACK RETURNING 0 + ELSE + GOBACK RETURNING 1 + END-IF + . +]) + +AT_CHECK([$COMPILE prog.cob], [0], [], []) +MANUAL_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) + +AT_CLEANUP + + +AT_SETUP([ACCEPT field WITH CURSOR literal]) +AT_KEYWORDS([position]) + +AT_SKIP_IF([test "$COB_HAS_CURSES" != "yes"]) + +AT_DATA([prog.cob], [ + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 success-flag PIC X VALUE 'Y'. + 88 success VALUE 'Y', 'y'. + 01 ws-x-20 PIC X(20). + PROCEDURE DIVISION. + testme. + set environment 'COB_SCREEN_EXCEPTIONS' to 'TRUE' + set environment 'COB_SCREEN_ESC' to 'TRUE' + + DISPLAY "If the cursor below is positioned at the 'C'" + LINE 1 COLUMN 1. + DISPLAY "(third column in field) below, then press ENTER." + LINE 2 COLUMN 1. + + MOVE "ABCDEFG " TO WS-X-20. + ACCEPT WS-X-20 + LINE 4 COLUMN 2 + WITH + AUTO-SKIP + SIZE 10 + CURSOR 3 + UPDATE. + + IF COB-CRT-STATUS = 0 + GOBACK RETURNING 0 + ELSE + GOBACK RETURNING 1 + END-IF + . +]) + +AT_CHECK([$COMPILE prog.cob], [0], [], []) +MANUAL_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) + +AT_CLEANUP + + +AT_SETUP([HOME key]) +AT_KEYWORDS([HOME SIZE]) + +AT_SKIP_IF([test "$COB_HAS_CURSES" != "yes"]) + +AT_DATA([prog.cob], [ + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 success-flag PIC X VALUE 'Y'. + 88 success VALUE 'Y', 'y'. + 01 ws-x-20 PIC X(20). + PROCEDURE DIVISION. + DISPLAY "Enter 'y' if multiple presses of the HOME key" + LINE 1 COLUMN 1. + DISPLAY "go to the beginning of the field and the beginning" + LINE 2 COLUMN 1. + DISPLAY "of the characters." + LINE 3 COLUMN 1. + + MOVE " ABC " TO WS-X-20. + ACCEPT WS-X-20 + LINE 5 COLUMN 1 + WITH + AUTO-SKIP + SIZE 10 + UPDATE. + + ACCEPT SUCCESS-FLAG + LINE 7 COLUMN 1 + WITH UPDATE. + + IF success AND COB-CRT-STATUS = 0 + GOBACK RETURNING 0 + ELSE + GOBACK RETURNING 1 + END-IF + . +]) + +AT_CHECK([$COMPILE prog.cob], [0], [], []) +MANUAL_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) + +AT_CLEANUP + + +AT_SETUP([END key]) +AT_KEYWORDS([END SIZE position]) + +AT_SKIP_IF([test "$COB_HAS_CURSES" != "yes"]) + +AT_DATA([prog.cob], [ + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 success-flag PIC X VALUE 'Y'. + 88 success VALUE 'Y', 'y'. + 01 ws-x-20 PIC X(20). + PROCEDURE DIVISION. + DISPLAY "Enter 'y' if multiple presses of the END key" + LINE 1 COLUMN 1. + DISPLAY "go to the end of the field and just after the end" + LINE 2 COLUMN 1. + DISPLAY "of the characters." + LINE 3 COLUMN 1. + + MOVE " ABC " TO WS-X-20. + ACCEPT WS-X-20 + LINE 5 COLUMN 1 + WITH + AUTO-SKIP + SIZE 10 + UPDATE. + + ACCEPT SUCCESS-FLAG + LINE 7 COLUMN 1 + WITH UPDATE. + + IF success AND COB-CRT-STATUS = 0 + GOBACK RETURNING 0 + ELSE + GOBACK RETURNING 1 + END-IF + . +]) + +AT_CHECK([$COMPILE prog.cob], [0], [], []) +MANUAL_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) + +AT_CLEANUP + + +AT_SETUP([INSERT key]) +AT_KEYWORDS([COB_INSERT_MODE SIZE]) + +AT_SKIP_IF([test "$COB_HAS_CURSES" != "yes"]) + +AT_DATA([prog.cob], [ + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 success-flag PIC X VALUE 'Y'. + 88 success VALUE 'Y', 'y'. + 01 ws-x-20 PIC X(20). + PROCEDURE DIVISION. + DISPLAY "Enter 'y' if multiple presses of the INSERT key" + LINE 1 COLUMN 1. + DISPLAY "go back and forth between" + LINE 2 COLUMN 1. + DISPLAY "Insert Mode ON (characters move to the right)" + LINE 3 COLUMN 1. + DISPLAY "and Insert Mode OFF (characters type over)." + LINE 4 COLUMN 1. + + MOVE "ABCD " TO WS-X-20. + ACCEPT WS-X-20 + LINE 6 COLUMN 1 + WITH + AUTO-SKIP + SIZE 10 + UPDATE. + + ACCEPT SUCCESS-FLAG + LINE 8 COLUMN 1 + WITH UPDATE. + + IF success AND COB-CRT-STATUS = 0 + GOBACK RETURNING 0 + ELSE + GOBACK RETURNING 1 + END-IF + . +]) + +AT_CHECK([$COMPILE prog.cob], [0], [], []) +MANUAL_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) + +AT_CLEANUP + + +AT_SETUP([cursor visibility]) +AT_KEYWORDS([COB_HIDE_CURSOR]) + +AT_SKIP_IF([test "$COB_HAS_CURSES" != "yes"]) + +AT_DATA([prog.cob], [ + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 success-flag PIC X VALUE 'Y'. + 88 fail VALUE 'N'. + 01 ws-input PIC X. + 88 success VALUE 'Y', 'y'. + PROCEDURE DIVISION. + DISPLAY "Type 'Y' if you see the cursor" + LINE 1 COLUMN 1. + + ACCEPT WS-INPUT + LINE 1 COLUMN 50 + WITH AUTO-SKIP + UPDATE. + IF NOT success SET fail TO TRUE. + + SET ENVIRONMENT 'COB_HIDE_CURSOR' TO 'TRUE'. + + DISPLAY "Type 'Y' if you do not see the cursor" + LINE 3 COLUMN 1. + + ACCEPT WS-INPUT + LINE 3 COLUMN 50 + WITH AUTO-SKIP + UPDATE. + IF NOT success SET fail TO TRUE. + + SET ENVIRONMENT 'COB_INSERT_MODE' TO 'TRUE'. + + DISPLAY "Type 'Y' if you still do not see the cursor" + LINE 5 COLUMN 1. + + ACCEPT WS-INPUT + LINE 5 COLUMN 50 + WITH AUTO-SKIP + UPDATE. + IF NOT success SET fail TO TRUE. + + IF fail + GOBACK RETURNING 1 + ELSE + GOBACK RETURNING 0 + END-IF + . +]) + +AT_CHECK([$COMPILE prog.cob], [0], [], []) +MANUAL_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) + +AT_CLEANUP + + +AT_SETUP([BACKSPACE key]) +AT_KEYWORDS([SIZE CURSOR position]) + +AT_SKIP_IF([test "$COB_HAS_CURSES" != "yes"]) + +AT_DATA([prog.cob], [ + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + ENVIRONMENT DIVISION. + CONFIGURATION SECTION. + SPECIAL-NAMES. + CURSOR IS cur-pos. + DATA DIVISION. + WORKING-STORAGE SECTION. + 77 cur-pos pic 9(06). + 01 success-flag PIC X VALUE 'Y'. + 88 success VALUE 'Y', 'y'. + 01 ws-x-20 PIC X(20). + PROCEDURE DIVISION. + DISPLAY "Enter 'y' if each press of the BACKSPACE key" + LINE 1 COLUMN 1. + DISPLAY "deletes the character to the left and moves the" + LINE 2 COLUMN 1. + DISPLAY "cursor and remaining characters one space to the" + LINE 3 COLUMN 1. + DISPLAY "left." + LINE 4 COLUMN 1. + + MOVE "ABCD " TO WS-X-20. + MOVE 006002 TO cur-pos. + ACCEPT WS-X-20 + LINE 6 COLUMN 1 + WITH + AUTO-SKIP + SIZE 10 + UPDATE. + + ACCEPT SUCCESS-FLAG + LINE 8 COLUMN 1 + WITH UPDATE. + + IF success AND COB-CRT-STATUS = 0 + GOBACK RETURNING 0 + ELSE + GOBACK RETURNING 1 + END-IF + . +]) + +AT_CHECK([$COMPILE prog.cob], [0], [], []) +MANUAL_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) + +AT_CLEANUP + + +AT_SETUP([DELETE key]) +AT_KEYWORDS([SIZE position]) + +AT_SKIP_IF([test "$COB_HAS_CURSES" != "yes"]) + +AT_DATA([prog.cob], [ + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 success-flag PIC X VALUE 'Y'. + 88 success VALUE 'Y', 'y'. + 01 ws-x-20 PIC X(20). + PROCEDURE DIVISION. + DISPLAY "Enter 'y' if each press of the DELETE key deletes" + LINE 1 COLUMN 1. + DISPLAY "the cursor character and moves the remaining" + LINE 2 COLUMN 1. + DISPLAY "characters one space to the left. And the cursor" + LINE 3 COLUMN 1. + DISPLAY "does not move." + LINE 4 COLUMN 1. + + MOVE "ABCD " TO WS-X-20. + ACCEPT WS-X-20 + LINE 6 COLUMN 1 + WITH + AUTO-SKIP + SIZE 10 + UPDATE. + + ACCEPT SUCCESS-FLAG + LINE 8 COLUMN 1 + WITH UPDATE. + + IF success AND COB-CRT-STATUS = 0 + GOBACK RETURNING 0 + ELSE + GOBACK RETURNING 1 + END-IF + . +]) + +AT_CHECK([$COMPILE prog.cob], [0], [], []) +MANUAL_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) + +AT_CLEANUP + + +AT_SETUP([ALT DELETE key]) +AT_KEYWORDS([ALT-DELETE SIZE]) + +AT_SKIP_IF([test "$COB_HAS_CURSES" != "yes"]) + +AT_DATA([prog.cob], [ + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 success-flag PIC X VALUE 'Y'. + 88 success VALUE 'Y', 'y'. + 01 ws-x-20 PIC X(20). + PROCEDURE DIVISION. + DISPLAY "Enter 'y' if pressing the ALT and DELETE keys" + LINE 1 COLUMN 1. + DISPLAY "deletes all characters from the cursor to the end" + LINE 2 COLUMN 1. + DISPLAY "of the field. And the cursor does not move." + LINE 3 COLUMN 1. + + MOVE "ABCD " TO WS-X-20. + ACCEPT WS-X-20 + LINE 5 COLUMN 1 + WITH + AUTO-SKIP + SIZE 10 + UPDATE. + + ACCEPT SUCCESS-FLAG + LINE 7 COLUMN 1 + WITH UPDATE. + + IF success AND COB-CRT-STATUS = 0 + GOBACK RETURNING 0 + ELSE + GOBACK RETURNING 1 + END-IF + . +]) + +AT_CHECK([$COMPILE prog.cob], [0], [], []) +MANUAL_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) + +AT_CLEANUP + + +AT_SETUP([ALT LEFT-ARROW key]) +AT_KEYWORDS([ALT-LEFT-ARROW SIZE]) + +AT_SKIP_IF([test "$COB_HAS_CURSES" != "yes"]) + +AT_DATA([prog.cob], [ + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 success-flag PIC X VALUE 'Y'. + 88 success VALUE 'Y', 'y'. + 01 ws-x-20 PIC X(20). + PROCEDURE DIVISION. + DISPLAY "Enter 'y' if pressing the ALT and LEFT-ARROW keys" + LINE 1 COLUMN 1. + DISPLAY "at the first column does not exit the field." + LINE 2 COLUMN 1. + DISPLAY "But the LEFT-ARROW without ALT does exit." + LINE 3 COLUMN 1. + + MOVE "ABCD " TO WS-X-20. + ACCEPT WS-X-20 + LINE 5 COLUMN 1 + WITH + AUTO-SKIP + SIZE 10 + UPDATE. + + ACCEPT SUCCESS-FLAG + LINE 7 COLUMN 1 + WITH UPDATE. + + IF success AND COB-CRT-STATUS = 0 + GOBACK RETURNING 0 + ELSE + GOBACK RETURNING 1 + END-IF + . +]) + +AT_CHECK([$COMPILE prog.cob], [0], [], []) +MANUAL_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) + +AT_CLEANUP + + +AT_SETUP([ALT RIGHT-ARROW key]) +AT_KEYWORDS([SIZE]) + +AT_SKIP_IF([test "$COB_HAS_CURSES" != "yes"]) + +AT_DATA([prog.cob], [ + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 success-flag PIC X VALUE 'Y'. + 88 success VALUE 'Y', 'y'. + 01 ws-x-10 PIC X(10). + PROCEDURE DIVISION. + DISPLAY "Enter 'y' if pressing the ALT and RIGHT-ARROW keys" + LINE 1 COLUMN 1. + DISPLAY "at the last column does not exit the field." + LINE 2 COLUMN 1. + DISPLAY "But the RIGHT-ARROW without ALT does exit." + LINE 3 COLUMN 1. + + MOVE "ABCDE" TO WS-X-10. + ACCEPT WS-X-10 + LINE 5 COLUMN 1 + WITH + AUTO-SKIP + SIZE 5 + UPDATE. + + ACCEPT SUCCESS-FLAG + LINE 7 COLUMN 1 + WITH UPDATE. + + IF success AND COB-CRT-STATUS = 0 + GOBACK RETURNING 0 + ELSE + GOBACK RETURNING 1 + END-IF + . +]) + +AT_CHECK([$COMPILE prog.cob], [0], [], []) +MANUAL_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) + +AT_CLEANUP + + +AT_SETUP([CURSOR clause]) +AT_KEYWORDS([SPECIAL-NAMES]) + +AT_SKIP_IF([test "$COB_HAS_CURSES" != "yes"]) + +AT_DATA([prog1.cob], [ + identification division. + program-id. prog. + + environment division. + configuration section. + special-names. + cursor is my-cur. + data division. + working-storage section. + + 01 my-cur. + 05 my-row pic 9(3) value 0. + 05 my-col pic 9(3) value 0. + + 77 loop pic 99. + 77 cursor-moves-here pic x(20). + + screen section. + + 01 screen-example . + 05 message1 value is "row (view only) is " line 1 col 10. + 05 filler pic 9(3) from my-row. + + 05 message2 value is "col (adjust only) is " line 2 col 10. + 05 filler pic 9(3) using my-col. + + 05 filler pic x(20) using cursor-moves-here line 3 col 14. + + procedure division. + + perform varying loop from 1 by 1 + until loop > 10 + display "screen accept no. " + at line 10 col 4 + loop "/10" + display screen-example + accept screen-example + end-perform + + goback. +]) + +# note: same test, but this time with different specified +# special-names reference +AT_DATA([prog2.cob], [ + identification division. + program-id. prog. + + data division. + working-storage section. + + 01 my-cur is special-names cursor. + 05 my-row pic 9(3) value 0. + 05 my-col pic 9(3) value 0. + + 77 loop pic 99. + 77 cursor-moves-here pic x(20). + + screen section. + + 01 screen-example . + 05 message1 value is "row (view only) is " line 1 col 10. + 05 filler pic 9(3) from my-row. + + 05 message2 value is "col (adjust only) is " line 2 col 10. + 05 filler pic 9(3) using my-col. + + 05 filler pic x(20) using cursor-moves-here line 3 col 14. + + procedure division. + + perform varying loop from 1 by 1 + until loop > 10 + display "screen accept no. " + at line 10 col 4 + loop "/10" + display screen-example + accept screen-example + end-perform + + goback. +]) + +AT_CHECK([$COMPILE prog1.cob], [0], [], []) +AT_CHECK([$COMPILE prog2.cob], [0], [], []) + +# user-instructions what to test is missing +AT_SKIP_IF([true]) + +MANUAL_CHECK([$COBCRUN_DIRECT ./prog1], [0], [], []) +MANUAL_CHECK([$COBCRUN_DIRECT ./prog2], [0], [], []) + +AT_CLEANUP + + +AT_SETUP([CRT STATUS clause]) +AT_KEYWORDS([SPECIAL-NAMES]) + +AT_SKIP_IF([test "$COB_HAS_CURSES" != "yes"]) + +AT_DATA([prog1.cob], [ + identification division. + program-id. prog. + + environment division. + configuration section. + special-names. + crt status is my-status. + data division. + working-storage section. + + 01 my-status. + 05 one pic X. + 05 two pic X. + 05 three pic X. + 05 four pic X. + + 77 loop pic 99. + 77 test-field pic x(5). + + screen section. + + 01 screen-example . + 05 message1 value is "status: " line 1 col 10. + 05 filler pic x(4) from my-status. + + 05 message2 value is "test-field: " line 2 col 10. + 05 filler pic x(5) using test-field. + + procedure division. + + set environment 'COB_SCREEN_EXCEPTIONS' to 'TRUE' + set environment 'COB_SCREEN_ESC' to 'TRUE' + perform varying loop from 1 by 1 + until loop > 10 + display "screen accept no. " + at line 10 col 4 + loop "/10" + display screen-example + accept screen-example + end-perform + + goback. +]) + +# note: same test, but this time with different specified +# special-names reference +AT_DATA([prog2.cob], [ + identification division. + program-id. prog. + + data division. + working-storage section. + + 77 my-status pic 9(05) is special-names crt status. + + 77 loop pic 99. + 77 test-field pic x(5). + + screen section. + + 01 screen-example . + 05 message1 value is "status: " line 1 col 10. + 05 filler pic 9(05) from my-status. + + 05 message2 value is "test-field: " line 2 col 10. + 05 filler pic x(5) using test-field. + + procedure division. + + set environment 'COB_SCREEN_EXCEPTIONS' to 'TRUE' + set environment 'COB_SCREEN_ESC' to 'TRUE' + perform varying loop from 1 by 1 + until loop > 10 + display "screen accept no. " + at line 10 col 4 + loop "/10" + display screen-example + accept screen-example + end-perform + + goback. +]) + +AT_CHECK([$COMPILE prog1.cob], [0], [], []) +AT_CHECK([$COMPILE prog2.cob], [0], [], []) + +# user-instructions what to test is missing +AT_SKIP_IF([true]) + +MANUAL_CHECK([$COBCRUN_DIRECT ./prog1], [0], [], []) +MANUAL_CHECK([$COBCRUN_DIRECT ./prog2], [0], [], []) + +AT_CLEANUP + + +AT_SETUP([CRT STATUS clause]) +AT_KEYWORDS([SPECIAL-NAMES]) + +AT_SKIP_IF([test "$COB_HAS_CURSES" != "yes"]) + +AT_DATA([prog.cob], [ + identification division. + program-id. prog-crt4. + + data division. + working-storage section. + + 01 crt4 pic 9(4) is special-names crt status. + + 01 test-tab. + 05 test-01 pic x(20) value "Function key 01 1001". + 05 test-02 pic x(20) value "Function key 02 1002". + 05 test-03 pic x(20) value "Function key 03 1003". + 05 test-04 pic x(20) value "Function key 04 1004". + 05 test-05 pic x(20) value "Function key 05 1005". + 05 test-06 pic x(20) value "Prev-page key 2001". + 05 test-07 pic x(20) value "Next-page key 2002". + + 01 test-rab-r redefines test-tab. + 05 test-data occurs 7 times. + 10 test-name pic x(16). + 10 test-crt4 pic 9(4). + + 01 linenr pic 9(2) value 0. + + 01 test-result-4 pic 9(4). + + 01 return-value pic 9 value 0. + + 77 loop pic 9(2). + 77 test-field pic x. + + + procedure division. + + set environment 'COB_SCREEN_EXCEPTIONS' to 'TRUE' + set environment 'COB_SCREEN_ESC' to 'TRUE' + + perform forever + display spaces with blank screen + + move 0 to return-value + perform varying loop from 1 by 1 until loop > 7 + compute linenr = loop + 5 + + display "Please press " line linenr, column 1 + display test-name(loop) line linenr, column 14 + + move spaces to test-field + accept test-field + line linenr column 30 + + display crt4 line linenr, column 30 + + if crt4 = test-crt4(loop) + display "passed" line linenr, column 36 + else + move 1 to return-value + display "failed" line linenr, column 36 + end-if + end-perform + + if return-value = 0 + exit perform + end-if + + display "Try again? (Y/n) " line 20, column 1 + move "Y" to test-field + accept test-field line 20, column 18 + if not (test-field = "Y" or "y") + exit perform + end-if + end-perform + + goback returning return-value + . +]) + +AT_CHECK([$COMPILE prog.cob], [0], [], []) + +MANUAL_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) + +AT_CLEANUP + + +AT_SETUP([X/Open CRT STATUS clause]) +AT_KEYWORDS([SPECIAL-NAMES]) + +AT_SKIP_IF([test "$COB_HAS_CURSES" != "yes"]) + +AT_DATA([prog.cob], [ + identification division. + program-id. prog-crt3. + + data division. + working-storage section. + + 01 crt3 is special-names crt status. + 05 crt3-1 pic 9. + 05 crt3-2 usage binary-char unsigned. + 05 crt3-3 usage binary-char unsigned. + + 01 test-tab. + 05 test-01 pic x(20) value "Function key 01 1001". + 05 test-02 pic x(20) value "Function key 02 1002". + 05 test-03 pic x(20) value "Function key 03 1003". + 05 test-04 pic x(20) value "Function key 04 1004". + 05 test-05 pic x(20) value "Function key 05 1005". + 05 test-06 pic x(20) value "Prev-page key 2001". + 05 test-07 pic x(20) value "Next-page key 2002". + + 01 test-rab-r redefines test-tab. + 05 test-data occurs 7 times. + 10 test-name pic x(16). + 10 test-crt31 pic 9. + 10 test-crt32 pic 9(3). + + 01 linenr pic 9(2) value 0. + + 01 test-result-1 pic 9. + 01 test-result-3 pic 9(3). + + 01 return-value pic 9 value 0. + + 77 loop pic 9(2). + 77 test-field pic x. + + + procedure division. + + set environment 'COB_SCREEN_EXCEPTIONS' to 'TRUE' + set environment 'COB_SCREEN_ESC' to 'TRUE' + + perform forever + display spaces with blank screen + + move 0 to return-value + perform varying loop from 1 by 1 until loop > 7 + compute linenr = loop + 5 + + display "Please press " line linenr, column 1 + display test-name(loop) line linenr, column 14 + + move spaces to test-field + accept test-field + line linenr column 30 + + move crt3-1 to test-result-1 + display test-result-1 line linenr, column 30 + + move crt3-2 to test-result-3 + display test-result-3 line linenr, column 32 + + if test-result-1 = test-crt31(loop) and + test-result-3 = test-crt32(loop) + display "passed" line linenr, column 36 + else + move 1 to return-value + display "failed" line linenr, column 36 + end-if + end-perform + + if return-value = 0 + exit perform + end-if + + display "Try again? (Y/n) " line 20, column 1 + move "Y" to test-field + accept test-field line 20, column 18 + if not (test-field = "Y" or "y") + exit perform + end-if + end-perform + + goback returning return-value + . +]) + +AT_CHECK([$COMPILE prog.cob], [0], [], []) + +MANUAL_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) + +AT_CLEANUP + +AT_SETUP([simple ACCEPT field WITH UPDATE]) +AT_KEYWORDS([screen]) + +AT_SKIP_IF([test "$COB_HAS_CURSES" != "yes"]) + +AT_DATA([prog.cob], [ + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 77 var pic x(11) value 'ignore this'. + 01 success-flag PIC X VALUE 'y'. + 88 success VALUE 'Y', 'y'. + + PROCEDURE DIVISION. + display "Press ENTER if you see an ""y"" " + at 0302 + accept success-flag update. + + IF success AND COB-CRT-STATUS = 0 + GOBACK RETURNING 0 + ELSE + GOBACK RETURNING 1 + END-IF + . +]) + +AT_CHECK([$COMPILE prog.cob], [0], [], []) +MANUAL_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) + +AT_CLEANUP + + +AT_SETUP([VALUE ALL in SCREEN SECTION]) + +AT_SKIP_IF([test "$COB_HAS_CURSES" != "yes"]) + +AT_DATA([prog.cob], [ + IDENTIFICATION DIVISION. + PROGRAM-ID. SCREEN-VALUE-ALL. + + DATA DIVISION. + WORKING-STORAGE SECTION. + + SCREEN SECTION. + 01 SCREEN001 BLANK SCREEN AUTO-SKIP. + 03 SCR01 BACKGROUND-COLOR 2 FOREGROUND-COLOR 7. + 05 LINE 02 COL 001 PIC X(50) VALUE ALL '-'. + + PROCEDURE DIVISION. + DISPLAY 'Press ENTER if you see a sequence of ""-""' + AT 0101 END-DISPLAY + DISPLAY ' ' AT 0201 END-DISPLAY + ACCEPT SCREEN001 + ACCEPT OMITTED + GOBACK. +]) + +AT_CHECK([$COMPILE prog.cob], [0], [], []) +MANUAL_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) + +AT_CLEANUP + + +AT_SETUP([CURSOR position in line 1]) +AT_KEYWORDS([screen]) + +AT_SKIP_IF([test "$COB_HAS_CURSES" != "yes"]) + +AT_DATA([prog.cob], [ + IDENTIFICATION DIVISION. + PROGRAM-ID. PROG. + ENVIRONMENT DIVISION. + CONFIGURATION SECTION. + SPECIAL-NAMES. + CURSOR IS CURSOR-POSITION. + + DATA DIVISION. + + WORKING-STORAGE SECTION. + + 01 CURSOR-POSITION. + 05 CSR-ROW-NUMBER PIC 9(03) VALUE 001. + 05 CSR-COL-NUMBER PIC 9(03) VALUE 005. + + 01 WORK-FIELDS. + 05 IN-ID PIC X(09) VALUE SPACES. + 05 TRAN-ID PIC X(03) VALUE 'ABC'. + + 01 SUCCESS-FLAG PIC X VALUE 'Y'. + 88 SUCCESS VALUE 'y', 'Y'. + + SCREEN SECTION. + + 01 EMPLOYEE-SCREEN + BACKGROUND-COLOR IS 0 + FOREGROUND-COLOR IS 7. + + 05 LINE 01 COL 01 AUTO PIC X(03) USING + TRAN-ID. + 05 LINE 01 COL 04 PIC X(01) VALUE + ','. + 05 LINE 01 COL 05 AUTO PIC X(09) USING + IN-ID. + + 05 LINE 5 VALUE 'cursor should be ' + & 'at line 1 and column 5'. + 05 LINE 6 VALUE 'go to line 10 ' + & 'and enter an "y" or "n" '. + 05 LINE 10 PIC X, REQUIRED USING success-flag. + + PROCEDURE DIVISION. + + DISPLAY EMPLOYEE-SCREEN. + ACCEPT EMPLOYEE-SCREEN. + + IF SUCCESS AND COB-CRT-STATUS = 0 + GOBACK RETURNING 0 + ELSE + GOBACK RETURNING 1 + END-IF. + +]) + +AT_CHECK([$COMPILE prog.cob], [0], [], []) +MANUAL_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) + +AT_CLEANUP + + +AT_SETUP([ACCEPT SCREEN TIMEOUT]) +AT_KEYWORDS([crt status cursor]) + +AT_SKIP_IF([test "$COB_HAS_CURSES" != "yes"]) + +AT_DATA([prog.cob], [ + REPLACE ==:BCOL:== BY ==BACKGROUND-COLOR==; ==:FCOL:== BY + ==FOREGROUND-COLOR==. + ** ************************************************************* + ** + ** ************************************************************* + IDENTIFICATION DIVISION. + PROGRAM-ID. PROG. + * GnuCOBOL sample + ENVIRONMENT DIVISION. + CONFIGURATION SECTION. + SPECIAL-NAMES. + CRT STATUS IS WCRT-STATUS. + CURSOR IS WCURSORROWCOL. + DATA DIVISION. + + WORKING-STORAGE SECTION. + 77 K-ENTER PIC 9(04) VALUE 0000. + 77 K-TIMEOUT PIC 9(04) VALUE 8001. + + 01 WCRT-STATUS PIC 9(04) VALUE ZERO. + 01 WCURSORROWCOL PIC 9(06) VALUE 000000. + 01 REDEFINES WCURSORROWCOL . + 05 WCURSORROW PIC 9(03). + 05 WCURSORCOL PIC 9(03). + 01 BLACK CONSTANT AS 00. + 01 BLUE CONSTANT AS 01. + 01 GREEN CONSTANT AS 02. + 01 CYAN CONSTANT AS 03. + 01 RED CONSTANT AS 04. + 01 MAGENTA CONSTANT AS 05. + * old color code as yellow + 01 BROWN CONSTANT AS 06. + * or Light Gray + 01 WHITE CONSTANT AS 07. + * or Dark Gray + 01 GREY CONSTANT AS 08. + * same color code as Grey + 01 LIGHTBLACK CONSTANT AS 08. + 01 LIGHTBLUE CONSTANT AS 09. + 01 LIGHTGREEN CONSTANT AS 10. + 01 LIGHTCYAN CONSTANT AS 11. + 01 LIGHTRED CONSTANT AS 12. + 01 LIGHTMAGENTA CONSTANT AS 13. + 01 PINK CONSTANT AS 13. + 01 YELLOW CONSTANT AS 14. + 01 LIGHTWHITE CONSTANT AS 15. + + + + 01 W-VAR-SELECTION. + 02 W-DATA PIC X(8). + 02 W-REPLY PIC X(01). + 88 SUCCESS VALUE 'Y', 'y'. + + + SCREEN SECTION. + + 01 SCREEN-SELECTION. + 02 LINE 06 COL 05 :FCOL: BLACK :BCOL: CYAN + VALUE 'TIMEOUT TEST - ENTER 4 CHARACTERS OF DATA' & + ' AND PAUSE UNTIL TIME CHANGES'. + 02 LINE 07 COL 05 :FCOL: BLACK :BCOL: CYAN + VALUE ' THEN ENTER 4 MORE CHARACTERS OF DATA' & + ' AND PAUSE UNTIL TIME CHANGES'. + 02 LINE 08 COL 05 :FCOL: BLACK :BCOL: CYAN + VALUE ' THEN AFTER THE TIME CHANGES ' & + ' ENTER A Y IN THE REPY LINE IF THE DATA ' & + ' IS CORRECT'. + + 02 LINE 15 COL 20 VALUE 'Data Entry:'. + 02 LINE + 2 COL 20 VALUE 'Reply:'. + 02 LINE 15 COL 40 PIC A(08) AUTO-SKIP USING W-DATA + HIGHLIGHT. + 02 LINE + 2 COL 40 PIC X AUTO-SKIP USING W-REPLY + HIGHLIGHT. + + PROCEDURE DIVISION. + + MAIN-LOOP. + DISPLAY SCREEN-SELECTION + CALL 'TIMEDISP' + + PERFORM WITH TEST AFTER UNTIL WCRT-STATUS <> K-TIMEOUT + ACCEPT SCREEN-SELECTION WITH TIMEOUT 1 + ON EXCEPTION CALL 'TIMEDISP' + END-ACCEPT + END-PERFORM. + + IF SUCCESS AND WCRT-STATUS = 0 + GOBACK RETURNING 0 + ELSE + GOBACK RETURNING 1 + END-IF + . + + GOBACK. + + ** ************************************************************* + * + ** ************************************************************* + ID DIVISION. + PROGRAM-ID. TIMEDISP. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 SWITCH PIC X. + 01 BLUE CONSTANT AS 01. + 01 RED CONSTANT AS 04. + 01 CYAN CONSTANT AS 03. + 01 WHITE CONSTANT AS 07. + 01 WDAY PIC 9(08). + 01 WTIME PIC 9(08). + 01 DATE-TIME PIC X(19). + PROCEDURE DIVISION. + ACCEPT WDAY FROM DATE YYYYMMDD + ACCEPT WTIME FROM TIME + STRING WDAY(1:4) '.' WDAY(5:2) '.' WDAY(7:2) ' ' + WTIME(1:2) ':' WTIME(3:2) ':' WTIME(5:2) DELIMITED BY + SIZE INTO DATE-TIME + IF SWITCH EQUAL 'N' + DISPLAY DATE-TIME AT 002061 :BCOL: CYAN :FCOL: WHITE + END-DISPLAY + MOVE 'Y' TO SWITCH + ELSE + DISPLAY DATE-TIME AT 002061 :BCOL: RED :FCOL: WHITE + END-DISPLAY + MOVE 'N' TO SWITCH + END-IF. + CONTINUE. + ENDPROGRAM. + GOBACK. + END PROGRAM TIMEDISP. + + END PROGRAM PROG. +]) + +AT_CHECK([$COMPILE prog.cob], [0], [], []) +MANUAL_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) + +AT_CLEANUP + + +AT_SETUP([system function CBL_GC_WINDOW]) +AT_KEYWORDS([screen]) + +AT_SKIP_IF([test "$COB_HAS_CURSES" != "yes"]) + +AT_DATA([prog.cob], [ +GNU >>SOURCE FORMAT IS FIXED +COBOL *> *************************************************************** + *> DATE: 20200630 + *> LICENSE: PUBLIC DOMAIN +COLORS*> PURPOSE: SHOW THE GNUCOBOL DEFAULT COLOUR PALETTE + *> TECTONICS: COBC -X GNUCOBOL-COLOURS.COB + *> *************************************************************** + IDENTIFICATION DIVISION. + PROGRAM-ID. SAMPLE. + + ENVIRONMENT DIVISION. + CONFIGURATION SECTION. + *SOURCE-COMPUTER. IBM-PC WITH DEBUGGING MODE. + OBJECT-COMPUTER. IBM-PC. + + REPOSITORY. + FUNCTION ALL INTRINSIC. + + DATA DIVISION. + WORKING-STORAGE SECTION. + + * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * + * * + * NEW WINDOW FUNCTIONS. * + * * + * CBL_GC_WINDOW * + * * + * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * + + 01 BLACK CONSTANT AS 0. + 01 BLUE CONSTANT AS 1. + 01 GREEN CONSTANT AS 2. + 01 CYAN CONSTANT AS 3. + 01 RED CONSTANT AS 4. + 01 MAGENTA CONSTANT AS 5. + 01 BROWN CONSTANT AS 6. + 01 WHITE CONSTANT AS 7. + + 77 ANSWER-TEXT PIC X. + + 01 SW-EVEN PIC X VALUE 'N'. + 01 CNTR PIC S9(9) COMP-5 VALUE +0. + 01 CNTR-ROW PIC S9(9) COMP-5 VALUE +0. + 01 CNTR-COL PIC S9(9) COMP-5 VALUE +0. + + 01 CURSOR-LOCN-BUFFER. + 05 CURSOR-LINE USAGE BINARY-CHAR UNSIGNED. + 05 CURSOR-COLUMN USAGE BINARY-CHAR UNSIGNED. + + 01 TMP. + 05 TMP-LINE PIC 9(4) COMP-5. + 05 TMP-COLUMN PIC 9(4) COMP-5. + + COPY 'gcwindow'. + + SCREEN SECTION. + 01 GNUCOBOL-COLOURS. + 05 LINE 1 COLUMN 1 VALUE "GNUCOBOL COLOURS". + 05 LINE 2 COLUMN 1 VALUE "==================". + + 05 LINE 4 COLUMN 1 VALUE "DEFAULT HIGHLIGHT " + & "LOWLIGHT REVERSE-VIDEO ". + 05 LINE 5 COLUMN 1 VALUE "------------------------------" + & "------------------------------". + + 05 LINE 7 COLUMN 1 VALUE "BLACK " FOREGROUND-COLOR BLACK. + 05 LINE + 1 COLUMN 1 VALUE "BLUE " FOREGROUND-COLOR BLUE. + 05 LINE + 1 COLUMN 1 VALUE "GREEN " FOREGROUND-COLOR GREEN. + 05 LINE + 1 COLUMN 1 VALUE "CYAN " FOREGROUND-COLOR CYAN. + 05 LINE + 1 COLUMN 1 VALUE "RED " FOREGROUND-COLOR RED. + 05 LINE + 1 COLUMN 1 VALUE "MAGENTA" FOREGROUND-COLOR MAGENTA. + 05 LINE + 1 COLUMN 1 VALUE "BROWN " FOREGROUND-COLOR BROWN. + 05 LINE + 1 COLUMN 1 VALUE "WHITE " FOREGROUND-COLOR WHITE. + *>BACKGROUND-COLOR BLACK. + + 05 LINE 7 COLUMN 16 VALUE "BLACK " + HIGHLIGHT FOREGROUND-COLOR BLACK. + *>BACKGROUND-COLOR WHITE. + 05 LINE + 1 COLUMN 16 VALUE "BLUE " + HIGHLIGHT FOREGROUND-COLOR BLUE. + 05 LINE + 1 COLUMN 16 VALUE "GREEN " + HIGHLIGHT FOREGROUND-COLOR GREEN. + 05 LINE + 1 COLUMN 16 VALUE "CYAN " + HIGHLIGHT FOREGROUND-COLOR CYAN. + 05 LINE + 1 COLUMN 16 VALUE "RED " + HIGHLIGHT FOREGROUND-COLOR RED. + 05 LINE + 1 COLUMN 16 VALUE "MAGENTA" + HIGHLIGHT FOREGROUND-COLOR MAGENTA. + 05 LINE + 1 COLUMN 16 VALUE "BROWN " + HIGHLIGHT FOREGROUND-COLOR BROWN. + 05 LINE + 1 COLUMN 16 VALUE "WHITE " + HIGHLIGHT FOREGROUND-COLOR WHITE + BACKGROUND-COLOR BLACK. + + 05 LINE 7 COLUMN 31 VALUE "BLACK " + LOWLIGHT FOREGROUND-COLOR BLACK. + *>BACKGROUND-COLOR WHITE. + 05 LINE + 1 COLUMN 31 VALUE "BLUE " + LOWLIGHT FOREGROUND-COLOR BLUE. + 05 LINE + 1 COLUMN 31 VALUE "GREEN " + LOWLIGHT FOREGROUND-COLOR GREEN. + 05 LINE + 1 COLUMN 31 VALUE "CYAN " + LOWLIGHT FOREGROUND-COLOR CYAN. + 05 LINE + 1 COLUMN 31 VALUE "RED " + LOWLIGHT FOREGROUND-COLOR RED. + 05 LINE + 1 COLUMN 31 VALUE "MAGENTA" + LOWLIGHT FOREGROUND-COLOR MAGENTA. + 05 LINE + 1 COLUMN 31 VALUE "BROWN " + LOWLIGHT FOREGROUND-COLOR BROWN. + 05 LINE + 1 COLUMN 31 VALUE "WHITE " + LOWLIGHT FOREGROUND-COLOR WHITE. + *>BACKGROUND-COLOR BLACK. + + 05 LINE 7 COLUMN 46 VALUE "BLACK " + REVERSE-VIDEO FOREGROUND-COLOR BLACK. + *>BACKGROUND-COLOR WHITE. + 05 LINE + 1 COLUMN 46 VALUE "BLUE " + REVERSE-VIDEO FOREGROUND-COLOR BLUE. + 05 LINE + 1 COLUMN 46 VALUE "GREEN " + REVERSE-VIDEO FOREGROUND-COLOR GREEN. + 05 LINE + 1 COLUMN 46 VALUE "CYAN " + REVERSE-VIDEO FOREGROUND-COLOR CYAN. + 05 LINE + 1 COLUMN 46 VALUE "RED " + REVERSE-VIDEO FOREGROUND-COLOR RED. + 05 LINE + 1 COLUMN 46 VALUE "MAGENTA" + REVERSE-VIDEO FOREGROUND-COLOR MAGENTA. + 05 LINE + 1 COLUMN 46 VALUE "BROWN " + REVERSE-VIDEO FOREGROUND-COLOR BROWN. + 05 LINE + 1 COLUMN 46 VALUE "WHITE " + REVERSE-VIDEO FOREGROUND-COLOR WHITE. + *>BACKGROUND-COLOR BLACK. + + *> 05 LINE 7 COLUMN 61 ERASE EOL. + *> 05 LINE + 1 COLUMN 61 ERASE EOL. + *> 05 LINE + 1 COLUMN 61 ERASE EOL. + *> 05 LINE + 1 COLUMN 61 ERASE EOL. + *> 05 LINE + 1 COLUMN 61 ERASE EOL. + *> 05 LINE + 1 COLUMN 61 ERASE EOL. + *> 05 LINE + 1 COLUMN 61 ERASE EOL. + *> 05 LINE + 1 COLUMN 61 ERASE EOL. + *> *************************************************************** + PROCEDURE DIVISION. + + MOVE ZERO TO CNTR. + * DISPLAY ' ' AT LINE 1 COLUMN 1. + CALL 'CBL_GC_SET_SCR_SIZE' USING 50, 80. + + * ACCEPT + * OMITTED + * LINE 16 COLUMN 1 + * END-ACCEPT. + + + DISPLAY ' YOU WILL SEE 4 WINDOWS OF ALTERNATING COLORS ' & + 'WAIT UNTIL THE END TO ANSWER-TEXT PROMPT' + AT LINE 1 COL 4. + + D DISPLAY ' ' UPON SYSERR + D DISPLAY ' STARTING NEW WINDOWS ' UPON SYSERR + D DISPLAY ' ' UPON SYSERR + + PERFORM 4 TIMES + ADD +5 TO CNTR + MOVE CNTR TO WP-WINDOW-START-ROW + MOVE CNTR TO WP-WINDOW-START-COL + MOVE 20 TO WP-WINDOW-ROWS + MOVE 60 TO WP-WINDOW-COLUMNS + IF SW-EVEN EQUAL 'Y' + MOVE 'N' TO SW-EVEN + MOVE 0 TO WP-WINDOW-FG-COLOR + MOVE 6 TO WP-WINDOW-BG-COLOR + ELSE + MOVE 'Y' TO SW-EVEN + MOVE 0 TO WP-WINDOW-FG-COLOR + MOVE 3 TO WP-WINDOW-BG-COLOR + END-IF + MOVE ZERO TO WP-WINDOW-HIDDEN + MOVE ZERO TO WP-WINDOW-RETURN-CODE + SET WP-MODE-NEW-WINDOW TO TRUE + PERFORM 1000-WINDOW-FUNCTION THRU 1000-EXIT + CALL 'CBL_GC_WINDOW' USING WL-WINDOW-LIST + PERFORM 3000-LIST-WINDOWS THRU 3000-EXIT + PERFORM 2000-WINDOW-CSR-POS THRU 2000-EXIT + DISPLAY GNUCOBOL-COLOURS + PERFORM 2000-WINDOW-CSR-POS THRU 2000-EXIT + CALL "C$SLEEP" USING 1 + END-PERFORM. + + + MOVE ZERO TO CNTR. + + D DISPLAY ' ' UPON SYSERR + D DISPLAY ' STARTING HIDE WINDOWS ' UPON SYSERR + D DISPLAY ' ' UPON SYSERR + + PERFORM 4 TIMES + ADD +1 TO CNTR + MOVE CNTR TO WP-WINDOW-NUMBER + MOVE 1 TO WP-WINDOW-HIDDEN + MOVE ZERO TO WP-WINDOW-RETURN-CODE + SET WP-MODE-HIDE-WINDOW TO TRUE + PERFORM 1000-WINDOW-FUNCTION THRU 1000-EXIT + CALL 'CBL_GC_WINDOW' USING WL-WINDOW-LIST + PERFORM 3000-LIST-WINDOWS THRU 3000-EXIT + CALL "C$SLEEP" USING 1 + END-PERFORM. + + + MOVE 5 TO CNTR. + + D DISPLAY ' ' UPON SYSERR + D DISPLAY ' STARTING SHOW WINDOWS ' UPON SYSERR + D DISPLAY ' ' UPON SYSERR + + PERFORM 4 TIMES + ADD -1 TO CNTR + MOVE CNTR TO WP-WINDOW-NUMBER + MOVE ZERO TO WP-WINDOW-HIDDEN + MOVE ZERO TO WP-WINDOW-RETURN-CODE + SET WP-MODE-SHOW-WINDOW TO TRUE + PERFORM 1000-WINDOW-FUNCTION THRU 1000-EXIT + CALL 'CBL_GC_WINDOW' USING WL-WINDOW-LIST + PERFORM 3000-LIST-WINDOWS THRU 3000-EXIT + CALL "C$SLEEP" USING 1 + PERFORM 2000-WINDOW-CSR-POS THRU 2000-EXIT + END-PERFORM. + + MOVE ZERO TO CNTR. + MOVE 10 TO CNTR-COL. + MOVE 10 TO CNTR-ROW. + + D DISPLAY ' ' UPON SYSERR + D DISPLAY ' STARTING MOVE WINDOWS ' UPON SYSERR + D DISPLAY ' STARTING TOP WINDOWS ' UPON SYSERR + D DISPLAY ' ' UPON SYSERR + + PERFORM 4 TIMES + PERFORM 2000-WINDOW-CSR-POS THRU 2000-EXIT + ADD +1 TO CNTR + ADD +2 TO CNTR-ROW + ADD +2 TO CNTR-COL + MOVE CNTR TO WP-WINDOW-NUMBER + MOVE CNTR-ROW TO WP-WINDOW-START-ROW + MOVE CNTR-COL TO WP-WINDOW-START-COL + MOVE 0 TO WP-WINDOW-HIDDEN + MOVE ZERO TO WP-WINDOW-RETURN-CODE + SET WP-MODE-MOVE-WINDOW TO TRUE + PERFORM 1000-WINDOW-FUNCTION THRU 1000-EXIT + CALL 'CBL_GC_WINDOW' USING WL-WINDOW-LIST + PERFORM 3000-LIST-WINDOWS THRU 3000-EXIT + MOVE CNTR TO WP-WINDOW-NUMBER + MOVE 0 TO WP-WINDOW-START-ROW + MOVE 0 TO WP-WINDOW-START-COL + MOVE 0 TO WP-WINDOW-HIDDEN + MOVE ZERO TO WP-WINDOW-RETURN-CODE + PERFORM 2000-WINDOW-CSR-POS THRU 2000-EXIT + SET WP-MODE-TOP-WINDOW TO TRUE + PERFORM 1000-WINDOW-FUNCTION THRU 1000-EXIT + PERFORM 2000-WINDOW-CSR-POS THRU 2000-EXIT + CALL "C$SLEEP" USING 1 + END-PERFORM. + + CALL "C$SLEEP" USING 1 + * ACCEPT + * OMITTED + * LINE 16 COLUMN 1 + * END-ACCEPT. + + MOVE ZERO TO CNTR. + + D DISPLAY ' ' UPON SYSERR + D DISPLAY ' STARTING BOTTOM WINDOWS ' UPON SYSERR + D DISPLAY ' ' UPON SYSERR + + PERFORM 4 TIMES + ADD +1 TO CNTR + MOVE CNTR TO WP-WINDOW-NUMBER + MOVE 1 TO WP-WINDOW-HIDDEN + MOVE ZERO TO WP-WINDOW-RETURN-CODE + SET WP-MODE-BOTTOM-WINDOW TO TRUE + PERFORM 1000-WINDOW-FUNCTION THRU 1000-EXIT + CALL 'CBL_GC_WINDOW' USING WL-WINDOW-LIST + PERFORM 3000-LIST-WINDOWS THRU 3000-EXIT + * CALL "C$SLEEP" USING 1 + END-PERFORM. + + MOVE ZERO TO CNTR. + + D DISPLAY ' ' UPON SYSERR + D DISPLAY ' STARTING DELETE WINDOWS ' UPON SYSERR + D DISPLAY ' ' UPON SYSERR + + PERFORM 4 TIMES + ADD +1 TO CNTR + MOVE CNTR TO WP-WINDOW-NUMBER + MOVE 1 TO WP-WINDOW-HIDDEN + MOVE ZERO TO WP-WINDOW-RETURN-CODE + SET WP-MODE-DELETE-WINDOW TO TRUE + PERFORM 1000-WINDOW-FUNCTION THRU 1000-EXIT + CALL 'CBL_GC_WINDOW' USING WL-WINDOW-LIST + PERFORM 3000-LIST-WINDOWS THRU 3000-EXIT + * CALL "C$SLEEP" USING 1 + END-PERFORM. + + DISPLAY ' DID YOU WILL SEE THEM CREATED, MOVED, HIDDEN, S' & + 'HOWN AND DELETED SUCCESSFULLY ?' + AT LINE 4 COL 4. + DISPLAY 'ANSWER Y OR N' + AT LINE 5 COL 10. + ACCEPT ANSWER-TEXT + AT LINE 5 COL 25. + + IF ANSWER-TEXT EQUAL 'Y' OR 'y' + MOVE ZERO TO RETURN-CODE + ELSE + MOVE 1 TO RETURN-CODE + END-IF. + + GOBACK. + + 1000-WINDOW-FUNCTION. + + CALL 'CBL_GC_WINDOW' USING WP-WINDOW-PARMS. + IF RETURN-CODE NOT EQUAL ZERO + D DISPLAY 'RETURN CODE IS ==> ' RETURN-CODE + D UPON SYSERR + MOVE 1 TO RETURN-CODE + GOBACK + END-IF. + + IF WP-WINDOW-RETURN-CODE NOT EQUAL ZERO + D DISPLAY 'WP-WINDOW-RETURN-CODE IS ==> ' + D WP-WINDOW-RETURN-CODE + D UPON SYSERR + MOVE 1 TO RETURN-CODE + GOBACK + END-IF. + + + 1000-EXIT. EXIT. + + 2000-WINDOW-CSR-POS. + + CALL "CBL_GET_CSR_POS" USING CURSOR-LOCN-BUFFER. + COMPUTE TMP-LINE = CURSOR-LINE + 1. + COMPUTE TMP-COLUMN = CURSOR-COLUMN + 1. + D DISPLAY ' WINDOW ==> ' WP-WINDOW-NUMBER + D ' CURSOR POSITION IS LINE ' + D TMP-LINE + D ' COLUMN ' + D TMP-COLUMN + D UPON SYSERR. + + 2000-EXIT. EXIT. + + 3000-LIST-WINDOWS. + + SET WL-INDEX TO +1. + D DISPLAY ' =========> START LISTING WINDOWS ' UPON SYSERR. + PERFORM 20 TIMES + IF WL-WINDOW (WL-INDEX) EQUAL LOW-VALUES + EXIT PERFORM + END-IF + D DISPLAY ' DEPTH => ' WL-DEPTH (WL-INDEX) + D ' NUMBER => ' WL-WINDOW-NUMBER (WL-INDEX) + D ' POS ROW => ' WL-WINDOW-POSITION-ROW (WL-INDEX) + D ' POS COL => ' WL-WINDOW-POSITION-COL (WL-INDEX) + D ' WIN ROW => ' WL-WINDOW-SIZE-ROW (WL-INDEX) + D ' WIN COL => ' WL-WINDOW-SIZE-COL (WL-INDEX) + D ' FG => ' WL-WINDOW-FG-COLOR (WL-INDEX) + D ' BG => ' WL-WINDOW-BG-COLOR (WL-INDEX) + D ' HIDDEN => ' WL-WINDOW-HIDDEN (WL-INDEX) + D UPON SYSERR + SET WL-INDEX UP BY +1 + END-PERFORM. + D DISPLAY ' =========> END LISTING WINDOWS ' UPON SYSERR. + + 3000-EXIT. EXIT. + END PROGRAM SAMPLE. +]) + +AT_CHECK([$COMPILE prog.cob], [0], [], []) +MANUAL_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) + +AT_CLEANUP From 0bf2ceb38ea46378e45ea0c865ef75c0374d94d6 Mon Sep 17 00:00:00 2001 From: sf-mensch Date: Mon, 18 Nov 2024 23:37:46 +0000 Subject: [PATCH 17/29] follow-up to r5369 - panel update * screenio.c [WITH_PANELS]: minor refactoring including move of return code out of PPARM_FLD * screenio.c (cob_sys_window): when function not available and in testmode, return 77 so test is skipped --- copy/gcwindow.cpy | 18 +- libcob/ChangeLog | 13 +- libcob/common.h | 14 +- libcob/screenio.c | 398 +- libcob/system.def | 2 - tests/testsuite.src/run_manual_screen.at | 8378 +++++++++++----------- 6 files changed, 4344 insertions(+), 4479 deletions(-) diff --git a/copy/gcwindow.cpy b/copy/gcwindow.cpy index 6b795be5f..146ddaa8f 100644 --- a/copy/gcwindow.cpy +++ b/copy/gcwindow.cpy @@ -47,12 +47,11 @@ *>* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *> * *> This copy member is used to call the Multiple Window * - *> CBL_GC_WINDOW functions. Note that in addition to * - *> checking the WP-WINDOW-RETURN-CODE field you should * - *> also check the COBOL RETURN-CODE as these functions * - *> only work when in extended i/o mode. See the * - *> Programmers Guide for more information on the use of * - *> these functions. * + *> CBL_GC_WINDOW functions. Note that the return value * + *> is passed via the COBOL RETURN-CODE; also note that these * + *> functions only work when in extended i/o mode. * + *> See the Programmers Guide for more information on the use * + *> of these functions. * *> * *>* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * @@ -74,7 +73,12 @@ 05 WP-WINDOW-FG-COLOR PIC 9(09) COMP-5. 05 WP-WINDOW-BG-COLOR PIC 9(09) COMP-5. 05 WP-WINDOW-HIDDEN PIC 9(09) COMP-5. - 05 WP-WINDOW-RETURN-CODE PIC 9(09) COMP-5. + + *> RETURN-CODE value + 01 WP-WINDOW-RETURN-CODE PIC 9(09) COMP-5. + 88 WP-UNSUPPORTED VALUE -1. + 88 WP-DISABLED VALUE -2. + 88 WP-BAD-PARAMETER-LEN VALUE -8. 88 WP-OK VALUE 0. 88 WP-START-Y-EXCEEDS-MAX VALUE 2. 88 WP-START-X-EXCEEDS-MAX VALUE 4. diff --git a/libcob/ChangeLog b/libcob/ChangeLog index 8396c3bef..7f6090b82 100644 --- a/libcob/ChangeLog +++ b/libcob/ChangeLog @@ -1,7 +1,16 @@ -2024-11-18 Chuck Haatvedt - * screenio.c added new functions for multiple window support. + +2024-10-04 Simon Sobisch + + * screenio.c [WITH_PANELS]: minor refactoring including move of + return code out of PPARM_FLD + * screenio.c (cob_sys_window): when function not available and in + testmode, return 77 so test is skipped + +2024-11-01 Chuck Haatvedt + + * screenio.c: added new functions for multiple window support; also added new static variables to support panel functions and a static array to store information about the panels which have been created. diff --git a/libcob/common.h b/libcob/common.h index ac3fda838..67f7ffeb8 100644 --- a/libcob/common.h +++ b/libcob/common.h @@ -2180,13 +2180,11 @@ COB_EXPIMP int cob_sys_clear_screen (void); COB_EXPIMP int cob_sys_sound_bell (void); COB_EXPIMP int cob_sys_get_scr_size (unsigned char *, unsigned char *); COB_EXPIMP int cob_sys_set_scr_size (unsigned char *, unsigned char *); -COB_EXPIMP int cob_sys_scr_dump (unsigned char *); -COB_EXPIMP int cob_sys_scr_restore (unsigned char *); -#ifdef COB_EXPERIMENTAL -COB_EXPIMP int cob_sys_window (void *); -#endif +COB_EXPIMP int cob_sys_scr_dump (unsigned char *); +COB_EXPIMP int cob_sys_scr_restore (unsigned char *); +COB_EXPIMP int cob_sys_window (unsigned char *); COB_EXPIMP int cob_sys_get_char (unsigned char *); -COB_EXPIMP int cob_get_text (char *, int); +COB_EXPIMP int cob_get_text (char *, int); COB_EXPIMP int cob_get_scr_cols (void); COB_EXPIMP int cob_get_scr_lines (void); COB_EXPIMP int cob_sys_get_csr_pos (unsigned char *); @@ -2868,8 +2866,8 @@ COB_EXPIMP cob_field *cob_intr_content_of (const int, const int, const int, ...); COB_EXPIMP cob_field *cob_intr_bit_of (cob_field *); COB_EXPIMP cob_field *cob_intr_bit_to_char (cob_field *); -COB_EXPIMP cob_field* cob_intr_hex_of (cob_field*); -COB_EXPIMP cob_field* cob_intr_hex_to_char (cob_field*); +COB_EXPIMP cob_field *cob_intr_hex_of (cob_field*); +COB_EXPIMP cob_field *cob_intr_hex_to_char (cob_field*); /************************/ /* Functions in cconv.c */ diff --git a/libcob/screenio.c b/libcob/screenio.c index a8a6d3690..30d744db5 100644 --- a/libcob/screenio.c +++ b/libcob/screenio.c @@ -215,7 +215,6 @@ typedef struct __PARM_FLD int fg_color; int bg_color; int hidden; - int ret_code; } PARM_FLD, *PPARM_FLD; typedef struct __LIST_FLD @@ -281,19 +280,6 @@ static unsigned int curr_setting_mouse_flags = UINT_MAX; static int cob_screen_init (void); -#ifdef WITH_PANELS -void cob_update_all_windows (void); -int check_panel_parm (PPARM_FLD parm); -int cob_new_window (PPARM_FLD parm); -int cob_move_window (PPARM_FLD parm); -int cob_show_window (PPARM_FLD parm); -int cob_hide_window (PPARM_FLD parm); -int cob_delete_window (PPARM_FLD parm); -int cob_top_window (PPARM_FLD parm); -int cob_bottom_window (PPARM_FLD parm); -int cob_list_window (PLIST_FLD list); -#endif - /* Local functions */ /* @@ -5283,86 +5269,77 @@ cob_init_screenio (cob_global *lptr, cob_settings *sptr) cob_settings_screenio (); } -/* These functions are only defined if we have PANELS */ - -#ifdef WITH_PANELS - /* Check the parms used for the panel functions */ -int +static int check_panel_parm (PPARM_FLD parm) { - if (mywin == stdscr) { - getyx (stdscr, save_cursor_y, save_cursor_x); - stdscr_fore_color = fore_color; - stdscr_back_color = back_color; - } - - parm->ret_code = 0; switch (parm->mode) { case CBL_NEW_WINDOW: if (parm->starty > COB_MAX_Y_COORD) - parm->ret_code = 2; + return 2; if (parm->startx > COB_MAX_X_COORD) - parm->ret_code = 4; + return 4; if (parm->win_rows > COB_MAX_Y_COORD) - parm->ret_code = 6; + return 6; if (parm->win_cols > COB_MAX_X_COORD) - parm->ret_code = 7; + return 7; if (parm->bg_color < 0 || parm->bg_color > 15) - parm->ret_code = 8; + return 8; if (parm->fg_color < 0 || parm->fg_color > 15) - parm->ret_code = 9; + return 9; if (parm->fg_color == parm->bg_color) - parm->ret_code = 11; + return 11; break; case CBL_DELETE_WINDOW: if (parm->pan_number < 1 || parm->pan_number > MAX_PANELS) - parm->ret_code = 10; + return 10; break; case CBL_MOVE_WINDOW: if (parm->starty > COB_MAX_Y_COORD) - parm->ret_code = 2; + return 2; if (parm->startx > COB_MAX_X_COORD) - parm->ret_code = 4; + return 4; if (parm->pan_number < 1 || parm->pan_number > MAX_PANELS) - parm->ret_code = 10; + return 10; break; case CBL_HIDE_WINDOW: if (parm->pan_number < 1 || parm->pan_number > MAX_PANELS) - parm->ret_code = 10; + return 10; if (parm->hidden != 1 ) - parm->ret_code = 12; + return 12; break; case CBL_SHOW_WINDOW: if (parm->pan_number < 1 || parm->pan_number > MAX_PANELS) - parm->ret_code = 10; + return 10; if (parm->hidden != 0 ) - parm->ret_code = 14; + return 14; break; case CBL_TOP_WINDOW: if (parm->pan_number < 1 || parm->pan_number > MAX_PANELS) - parm->ret_code = 16; + return 16; break; case CBL_BOTTOM_WINDOW: if (parm->pan_number < 1 || parm->pan_number > MAX_PANELS) - parm->ret_code = 18; + return 18; break; + default: + return 99; } - return parm->ret_code; + return 0; } +/* These functions are only defined if we have PANELS */ + +#ifdef WITH_PANELS + /* this function updates all the windows which are not hidden and then does the final "doupdate" to update the physical screen */ -void +static void cob_update_all_windows (void) { - PANEL *ptr_pan; - WINDOW *ptr_win; - /* first get the top panel */ - - ptr_pan =ceiling_panel(NULL); + PANEL *ptr_pan = ceiling_panel (NULL); if (!ptr_pan) { mywin = stdscr; @@ -5371,106 +5348,22 @@ cob_update_all_windows (void) return; } - update_panels(); + update_panels (); - for(;ptr_pan;) { - ptr_win = panel_window (ptr_pan); - wnoutrefresh(ptr_win); - ptr_pan = panel_below(ptr_pan); + while (ptr_pan) { + WINDOW *ptr_win = panel_window (ptr_pan); + wnoutrefresh (ptr_win); + ptr_pan = panel_below (ptr_pan); } refresh_mywin (mywin); - doupdate(); + doupdate (); } -#endif - -/* CBL_GC_WINDOW - window functions */ -#ifdef COB_EXPERIMENTAL -int -cob_sys_window (unsigned char *a) -{ - -#ifndef WITH_PANELS - COB_UNUSED (a); - return -1; -#else - - cob_field *f1 = cob_get_param_field (1, "ANYPGM"); - PPARM_FLD parm; - PLIST_FLD list; - int ret; - - COB_CHK_PARMS (CBL_GC_NEW_WINDOW, 1); - init_cob_screen_if_needed (); - - if (f1->size == MAX_PANELS * sizeof (LIST_FLD)) { - list = a; - return (cob_list_window(list)); - } - - if (f1->size == sizeof (PARM_FLD)) { - parm = a; - ret = check_panel_parm(parm); - switch (ret) { - case 99: - return -4; - break; - case 0: - break; - default: - parm->ret_code = ret; - return -1; - break; - } - } else { - return -8; - } - - switch (parm->mode) { - case CBL_NEW_WINDOW: - return (cob_new_window (parm)); - break; - case CBL_DELETE_WINDOW: - return (cob_delete_window (parm)); - break; - case CBL_MOVE_WINDOW: - return (cob_move_window (parm)); - break; - case CBL_HIDE_WINDOW: - return (cob_hide_window (parm)); - break; - case CBL_SHOW_WINDOW: - return (cob_show_window (parm)); - break; - case CBL_TOP_WINDOW: - return (cob_top_window (parm)); - break; - case CBL_BOTTOM_WINDOW: - return (cob_bottom_window (parm)); - break; - default: - parm->ret_code = 44; - return -1; - break; - } -#endif - -} -#endif - - - /* NEW_WINDOW - create a new panel / window pair */ -int +static int cob_new_window (PPARM_FLD parm) { - -#ifndef WITH_PANELS - COB_UNUSED (a); - return -1; -#else - PPANEL_ENTRY pan_first = &my_panels[0]; PPANEL_ENTRY pan_last = &my_panels[MAX_PANELS]; PPANEL_ENTRY ptr_pan_entry; @@ -5492,8 +5385,7 @@ cob_new_window (PPARM_FLD parm) /* if no empty slot exists then set error code */ if (ptr_pan_entry > pan_last) { - parm->ret_code = 20; - return -1; + return 20; } ptr_win = newwin(parm->win_rows, @@ -5501,14 +5393,12 @@ cob_new_window (PPARM_FLD parm) parm->starty - 1, parm->startx - 1); if (!ptr_win) { - parm->ret_code = 22; - return -1; + return 22; } ptr_pan = new_panel(ptr_win); if (!ptr_pan) { - parm->ret_code = 24; - return -1; + return 24; } cob_to_curses_color (parm->fg_color, &fg_color); @@ -5524,8 +5414,7 @@ cob_new_window (PPARM_FLD parm) ptr_pan_entry->hidden = 0; if (set_panel_userptr (ptr_pan, ptr_pan_entry)) { - parm->ret_code = 26; - return -1; + return 26; } mywin = ptr_win; @@ -5538,26 +5427,19 @@ cob_new_window (PPARM_FLD parm) ptr_pan_entry->bg_color = bg_color; ptr_pan_entry->input_fg_color = parm->fg_color; ptr_pan_entry->input_bg_color = parm->bg_color; - color_pr = cob_get_color_pair(fg_color, bg_color); - wbkgd (mywin ,COLOR_PAIR(color_pr)); + color_pr = cob_get_color_pair (fg_color, bg_color); + wbkgd (mywin ,COLOR_PAIR (color_pr)); werase(mywin); fore_color = fg_color; back_color = bg_color; cob_update_all_windows (); return 0; -#endif } /* MOVE_WINDOW - move the panel within stdscr */ -int +static int cob_move_window (PPARM_FLD parm) { - -#ifndef WITH_PANELS - COB_UNUSED (a); - return -1; -#else - PPANEL_ENTRY ptr_pan_entry; PANEL *ptr_pan; @@ -5565,22 +5447,17 @@ cob_move_window (PPARM_FLD parm) ptr_pan_entry = &my_panels[parm->pan_number - 1]; if (!ptr_pan_entry->pan) { - parm->ret_code = 28; - return -1; + return 28; } ptr_pan = ptr_pan_entry->pan; if (!panel_hidden(ptr_pan_entry->pan)) { - parm->ret_code = 40; - return -1; + return 40; } - if (move_panel (ptr_pan, - parm->starty - 1, - parm->startx - 1) ) { - parm->ret_code = 29; - return -1; + if (move_panel (ptr_pan, parm->starty - 1, parm->startx - 1) ) { + return 29; } ptr_pan_entry->startx = parm->startx - 1; @@ -5602,20 +5479,13 @@ cob_move_window (PPARM_FLD parm) cob_update_all_windows (); return 0; -#endif } /* SHOW_WINDOW - show the panel within stdscr */ -int +static int cob_show_window (PPARM_FLD parm) { - -#ifndef WITH_PANELS - COB_UNUSED (a); - return -1; -#else - PPANEL_ENTRY ptr_pan_entry; PANEL *ptr_pan; @@ -5623,20 +5493,17 @@ cob_show_window (PPARM_FLD parm) ptr_pan_entry = &my_panels[parm->pan_number - 1]; if (!ptr_pan_entry->pan) { - parm->ret_code = 28; - return -1; + return 28; } if (panel_hidden(ptr_pan_entry->pan)) { - parm->ret_code = 42; - return -1; + return 42; } ptr_pan = ptr_pan_entry->pan; if (show_panel(ptr_pan)) { - parm->ret_code = 30; - return -1; + return 30; } ptr_pan_entry->hidden = 0; @@ -5657,19 +5524,12 @@ cob_show_window (PPARM_FLD parm) cob_update_all_windows (); return 0; -#endif } /* HIDE_WINDOW - hide the panel within stdscr */ -int +static int cob_hide_window (PPARM_FLD parm) { - -#ifndef WITH_PANELS - COB_UNUSED (a); - return -1; -#else - PPANEL_ENTRY ptr_pan_entry; PANEL *ptr_pan; @@ -5677,20 +5537,17 @@ cob_hide_window (PPARM_FLD parm) ptr_pan_entry = &my_panels[parm->pan_number - 1]; if (!ptr_pan_entry->pan) { - parm->ret_code = 28; - return -1; + return 28; } ptr_pan = ptr_pan_entry->pan; if (!panel_hidden(ptr_pan_entry->pan)) { - parm->ret_code = 40; - return -1; + return 40; } if (hide_panel(ptr_pan)) { - parm->ret_code = 32; - return -1; + return 32; } ptr_pan_entry->hidden = 1; @@ -5722,20 +5579,13 @@ cob_hide_window (PPARM_FLD parm) cob_update_all_windows (); return 0; -#endif } /* TOP_WINDOW - top the panel within stdscr */ -int +static int cob_top_window (PPARM_FLD parm) { - -#ifndef WITH_PANELS - COB_UNUSED (a); - return -1; -#else - PPANEL_ENTRY ptr_pan_entry; PANEL *ptr_pan; @@ -5743,20 +5593,17 @@ cob_top_window (PPARM_FLD parm) ptr_pan_entry = &my_panels[parm->pan_number - 1]; if (!ptr_pan_entry->pan) { - parm->ret_code = 28; - return -1; + return 28; } ptr_pan = ptr_pan_entry->pan; if (!panel_hidden(ptr_pan_entry->pan)) { - parm->ret_code = 40; - return -1; + return 40; } if (top_panel(ptr_pan)) { - parm->ret_code = 34; - return -1; + return 34; } ptr_pan = ceiling_panel(NULL); @@ -5775,20 +5622,13 @@ cob_top_window (PPARM_FLD parm) cob_update_all_windows (); return 0; -#endif } /* BOTTOM_WINDOW - top the panel within stdscr */ -int +static int cob_bottom_window (PPARM_FLD parm) { - -#ifndef WITH_PANELS - COB_UNUSED (a); - return -1; -#else - PPANEL_ENTRY ptr_pan_entry; PANEL *ptr_pan; @@ -5796,20 +5636,17 @@ cob_bottom_window (PPARM_FLD parm) ptr_pan_entry = &my_panels[parm->pan_number - 1]; if (!ptr_pan_entry->pan) { - parm->ret_code = 28; - return -1; + return 28; } ptr_pan = ptr_pan_entry->pan; if (!panel_hidden(ptr_pan_entry->pan)) { - parm->ret_code = 40; - return -1; + return 40; } if (bottom_panel(ptr_pan)) { - parm->ret_code = 35; - return -1; + return 35; } ptr_pan = ceiling_panel(NULL); @@ -5829,19 +5666,12 @@ cob_bottom_window (PPARM_FLD parm) cob_update_all_windows (); return 0; -#endif } /* DELETE_WINDOW - delete the panel within stdscr */ -int +static int cob_delete_window (PPARM_FLD parm) { - -#ifndef WITH_PANELS - COB_UNUSED (a); - return -1; -#else - PPANEL_ENTRY ptr_pan_entry; PANEL *ptr_pan; @@ -5849,24 +5679,19 @@ cob_delete_window (PPARM_FLD parm) ptr_pan_entry = &my_panels[parm->pan_number - 1]; if (!ptr_pan_entry->pan) { - parm->ret_code = 28; - return -1; + return 28; } if (!panel_hidden(ptr_pan_entry->pan)) { show_panel( ptr_pan_entry->pan); } - if (del_panel(ptr_pan_entry->pan)) { - parm->ret_code = 38; + if (del_panel (ptr_pan_entry->pan)) { + return 38; } - if (delwin(ptr_pan_entry->win)) { - parm->ret_code = 36; - } - - if (parm->ret_code) { - return -1; + if (delwin (ptr_pan_entry->win)) { + return 36; } ptr_pan_entry->pan = NULL; @@ -5890,7 +5715,7 @@ cob_delete_window (PPARM_FLD parm) back_color = ptr_pan_entry->bg_color; } else { mywin = stdscr; - move(save_cursor_y, save_cursor_x); + move (save_cursor_y, save_cursor_x); fore_color = stdscr_fore_color; back_color = stdscr_back_color; } @@ -5905,20 +5730,13 @@ cob_delete_window (PPARM_FLD parm) cob_update_all_windows (); return 0; -#endif } /* LIST_WINDOW - list all of the windows */ -int +static int cob_list_window (PLIST_FLD list) { - -#ifndef WITH_PANELS - COB_UNUSED (a); - return -1; -#else - PPANEL_ENTRY ptr_pan_entry; PANEL *ptr_pan; int depth, loop; @@ -5959,5 +5777,81 @@ cob_list_window (PLIST_FLD list) } } return 0; -#endif } + +#endif /* WITH_PANELS */ + + +/* CBL_GC_WINDOW - window functions */ +int +cob_sys_window (unsigned char *fld) +{ +#ifdef COB_EXPERIMENTAL + const cob_field *f1 = cob_get_param_field (1, "ANYPGM"); + PPARM_FLD parm; + int ret; + + COB_CHK_PARMS (CBL_GC_NEW_WINDOW, 1); + COB_UNUSED (fld); + init_cob_screen_if_needed (); + + if (f1->size == sizeof (PARM_FLD)) { + parm = (PPARM_FLD)f1->data; + ret = check_panel_parm (parm); + if (ret) { + return ret; + } + } else if (f1->size == MAX_PANELS * sizeof (LIST_FLD)) { +#ifdef WITH_PANELS + return (cob_list_window ((PLIST_FLD)f1->data)); +#endif + } else { + return -8; + } + +#ifdef WITH_PANELS + + if (mywin == stdscr) { + getyx (stdscr, save_cursor_y, save_cursor_x); + stdscr_fore_color = fore_color; + stdscr_back_color = back_color; + } + + switch (parm->mode) { + case CBL_NEW_WINDOW: return (cob_new_window (parm)); + case CBL_DELETE_WINDOW: return (cob_delete_window (parm)); + case CBL_MOVE_WINDOW: return (cob_move_window (parm)); + case CBL_HIDE_WINDOW: return (cob_hide_window (parm)); + case CBL_SHOW_WINDOW: return (cob_show_window (parm)); + case CBL_TOP_WINDOW: return (cob_top_window (parm)); + case CBL_BOTTOM_WINDOW: return (cob_bottom_window (parm)); + default: + return 44; + } + +#else + if (getenv ("COB_IS_RUNNING_IN_TESTMODE")) { + return 77; /* let testsuite skip related tests */ + } + return -1; +#endif + + +#else /* COB_EXPERIMENTAL */ + COB_UNUSED (fld); + COB_UNUSED (check_panel_parm); + COB_UNUSED (cob_new_window); + COB_UNUSED (cob_delete_window); + COB_UNUSED (cob_move_window); + COB_UNUSED (cob_hide_window); + COB_UNUSED (cob_show_window); + COB_UNUSED (cob_top_window); + COB_UNUSED (cob_bottom_window); + COB_UNUSED (cob_list_window); + if (getenv ("COB_IS_RUNNING_IN_TESTMODE")) { + return 77; /* let testsuite skip related tests */ + } + return -2; +#endif + +} \ No newline at end of file diff --git a/libcob/system.def b/libcob/system.def index 6eae2b3f1..29798ce31 100644 --- a/libcob/system.def +++ b/libcob/system.def @@ -44,9 +44,7 @@ COB_SYSTEM_GEN ("CBL_GET_CURRENT_DIR", 3, 3, cob_sys_get_current_dir) COB_SYSTEM_GEN ("CBL_GET_SCR_SIZE", 2, 2, cob_sys_get_scr_size) COB_SYSTEM_GEN ("CBL_GC_SCR_DUMP", 1, 1, cob_sys_scr_dump) COB_SYSTEM_GEN ("CBL_GC_SCR_RESTORE", 1, 1, cob_sys_scr_restore) -#ifdef COB_EXPERIMENTAL COB_SYSTEM_GEN ("CBL_GC_WINDOW", 1, 1, cob_sys_window) -#endif COB_SYSTEM_GEN ("CBL_IMP", 3, 3, cob_sys_imp) COB_SYSTEM_GEN ("CBL_NIMP", 3, 3, cob_sys_nimp) COB_SYSTEM_GEN ("CBL_NOR", 3, 3, cob_sys_nor) diff --git a/tests/testsuite.src/run_manual_screen.at b/tests/testsuite.src/run_manual_screen.at index d9334d56f..c4d30f0f9 100644 --- a/tests/testsuite.src/run_manual_screen.at +++ b/tests/testsuite.src/run_manual_screen.at @@ -1,4208 +1,4170 @@ -## Copyright (C) 2014-2018,2020-2024 Free Software Foundation, Inc. -## Written by Edward Hart, Simon Sobisch, Chuck Haatvedt -## -## This file is part of GnuCOBOL. -## -## The GnuCOBOL compiler is free software: you can redistribute it -## and/or modify it under the terms of the GNU General Public License -## as published by the Free Software Foundation, either version 3 of the -## License, or (at your option) any later version. -## -## GnuCOBOL is distributed in the hope that it will be useful, -## but WITHOUT ANY WARRANTY; without even the implied warranty of -## MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -## GNU General Public License for more details. -## -## You should have received a copy of the GNU General Public License -## along with GnuCOBOL. If not, see . - -### GnuCOBOL Test Suite - -### ISO+IEC+1989-2014 9.2 Screens, 13.17 Screen description entry, 13.18 Data -### division clauses. - -AT_SETUP([LINE]) -AT_KEYWORDS([screen]) - -AT_SKIP_IF([test "$COB_HAS_CURSES" != "yes"]) - -AT_DATA([prog.cob], [ - IDENTIFICATION DIVISION. - PROGRAM-ID. prog. - DATA DIVISION. - WORKING-STORAGE SECTION. - 01 success-flag PIC X VALUE 'Y'. - 88 success VALUE 'Y', 'y'. - - SCREEN SECTION. - 01 scr. - 03 LINE 1 VALUE 'Enter "y" if the numbers below correspond ' - & 'to their line number and are in the '. - 03 LINE 2 VALUE 'first column. (This is line 2.)'. - 03 LINE 3 VALUE '3'. - 03 LINE 4 VALUE '4'. - 03 LINE 5 VALUE '5'. - 03 group-1 LINE - 3. - 05 group-2 COL 5. - 07 LINE PLUS 6 VALUE '8'. - 07 LINE MINUS 2 VALUE '6'. - 03 group-3 LINE + 1. - 05 COL 1 VALUE '7'. - 03 LINE + 3 PIC X, REQUIRED USING success-flag. - - PROCEDURE DIVISION. - DISPLAY scr - ACCEPT scr - - IF success AND COB-CRT-STATUS = 0 - GOBACK RETURNING 0 - ELSE - GOBACK RETURNING 1 - END-IF - . -]) - -AT_CHECK([$COMPILE prog.cob], [0], [], []) -MANUAL_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) - -AT_CLEANUP - - -AT_SETUP([COLUMN (1)]) -AT_KEYWORDS([COL]) - -AT_SKIP_IF([test "$COB_HAS_CURSES" != "yes"]) - -AT_DATA([prog.cob], [ - IDENTIFICATION DIVISION. - PROGRAM-ID. prog. - DATA DIVISION. - WORKING-STORAGE SECTION. - 01 dummy PIC X(5). - 01 success-flag PIC X VALUE 'Y'. - 88 success VALUE 'Y', 'y'. - - SCREEN SECTION. - 01 scr. - 03 VALUE 'Enter "y" if the numbers below correspond to ' - & 'their column number.'. - 03 LINE 2 VALUE '123456789'. - 03 LINE 3 COLUMN 2. - 05 COL 1 VALUE '1'. - 05 COL 5 VALUE '5'. - 05 COL MINUS 2 VALUE '3'. - 05 COL PLUS 1 VALUE '4'. - 05 group-1 LINE 3. - 07 VALUE '2'. - 07 group-2 COLUMN + 4. - 09 group-3. - 11 COL + 0 VALUE '6'. - 05 COLUMN + 1, VALUE '7'. - 03 LINE 5 PIC X, REQUIRED, USING success-flag. - - PROCEDURE DIVISION. - DISPLAY scr - ACCEPT scr - - IF success AND COB-CRT-STATUS = 0 - GOBACK RETURNING 0 - ELSE - GOBACK RETURNING 1 - END-IF - . -]) - -AT_CHECK([$COMPILE prog.cob], [0], [], []) -MANUAL_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) - -AT_CLEANUP - - -AT_SETUP([COLUMN (2)]) -AT_KEYWORDS([COL]) - -AT_SKIP_IF([test "$COB_HAS_CURSES" != "yes"]) - -AT_DATA([prog.cob], [ - IDENTIFICATION DIVISION. - PROGRAM-ID. prog. - - DATA DIVISION. - WORKING-STORAGE SECTION. - 01 dummy-1 PIC X(10). - 01 dummy-2 PIC X(10). - 01 dummy-3 PIC X(10). - - 01 success-flag PIC X VALUE 'Y'. - 88 success VALUE 'Y', 'y'. - - SCREEN SECTION. - 01 scr. - 03 PIC X(80) VALUE 'Enter "y" if there are three non-'- - 'overlapping input fields on one line below.'. - 03 LINE + 1, PIC X(80) VALUE 'field.'. - 03 LINE + 2, PIC X(10) TO dummy-1. - 03 COL + 2, PIC X(10) TO dummy-2. - 03 COL + 2, PIC X(10) TO dummy-3. - 03 success-field LINE + 2, PIC X, REQUIRED, - USING success-flag. - - PROCEDURE DIVISION. - DISPLAY scr - ACCEPT scr - - IF success AND COB-CRT-STATUS = 0 - GOBACK RETURNING 0 - ELSE - GOBACK RETURNING 1 - END-IF - . -]) - -AT_CHECK([$COMPILE prog.cob], [0], [], []) -MANUAL_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) - -AT_CLEANUP - - -AT_SETUP([LINE non-zero, COLUMN zero]) -AT_KEYWORDS([COL extensions]) - -AT_SKIP_IF([test "$COB_HAS_CURSES" != "yes"]) - -AT_DATA([prog.cob], [ - IDENTIFICATION DIVISION. - PROGRAM-ID. prog. - DATA DIVISION. - WORKING-STORAGE SECTION. - 01 success-flag PIC X VALUE 'Y'. - 88 success VALUE 'Y', 'y'. - - SCREEN SECTION. - 01 scr. - 03 LINE 1 VALUE 'Enter "y" if you see 123 on the line '- - 'below starting at column 1.'. - 03 LINE + 3 PIC X, REQUIRED USING success-flag. - 03 LINE 2 VALUE '1'. - - PROCEDURE DIVISION. - DISPLAY scr - DISPLAY '2' LINE 2, COLUMN 0; '3' - ACCEPT scr - - IF success AND COB-CRT-STATUS = 0 - GOBACK RETURNING 0 - ELSE - GOBACK RETURNING 1 - END-IF - . -]) - -AT_CHECK([$COMPILE prog.cob], [0], [], []) -MANUAL_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) - -AT_CLEANUP - - -AT_SETUP([LINE zero, COLUMN non-zero]) -AT_KEYWORDS([COL zero extensions]) - -AT_SKIP_IF([test "$COB_HAS_CURSES" != "yes"]) - -AT_DATA([prog.cob], [ - IDENTIFICATION DIVISION. - PROGRAM-ID. prog. - DATA DIVISION. - WORKING-STORAGE SECTION. - 01 success-flag PIC X VALUE 'Y'. - 88 success VALUE 'Y', 'y'. - - SCREEN SECTION. - 01 scr. - 03 LINE 1 VALUE 'Enter "y" if you see 123 on the line '- - 'below starting at column 1.'. - 03 LINE + 3 PIC X, REQUIRED USING success-flag. - 03 LINE 2 COL 3, VALUE '3'. - 03 LINE 1 COL 80 VALUE ' '. - - PROCEDURE DIVISION. - DISPLAY scr - DISPLAY '1' LINE 0, COLUMN 1; '2' - ACCEPT scr - - IF success AND COB-CRT-STATUS = 0 - GOBACK RETURNING 0 - ELSE - GOBACK RETURNING 1 - END-IF - . -]) - -AT_CHECK([$COMPILE prog.cob], [0], [], []) -MANUAL_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) - -AT_CLEANUP - - -AT_SETUP([LINE zero, COLUMN zero]) -AT_KEYWORDS([COL extensions]) - -AT_SKIP_IF([test "$COB_HAS_CURSES" != "yes"]) - -AT_DATA([prog.cob], [ - IDENTIFICATION DIVISION. - PROGRAM-ID. prog. - DATA DIVISION. - WORKING-STORAGE SECTION. - 01 success-flag PIC X VALUE 'Y'. - 88 success VALUE 'Y', 'y'. - - SCREEN SECTION. - 01 scr. - 03 LINE 1 VALUE 'Enter "y" if you see 1234 on the line '- - 'below starting at column 1.'. - 03 LINE + 3 PIC X, REQUIRED USING success-flag. - 03 LINE 2 VALUE '1'. - - PROCEDURE DIVISION. - DISPLAY scr - DISPLAY '2' LINE 0, COLUMN 0 - DISPLAY '3' LINE 2, COLUMN 3 - DISPLAY '4' AT 0000 - - ACCEPT scr - - IF success AND COB-CRT-STATUS = 0 - GOBACK RETURNING 0 - ELSE - GOBACK RETURNING 1 - END-IF - . -]) - -AT_CHECK([$COMPILE prog.cob], [0], [], []) -MANUAL_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) - -AT_CLEANUP - - -AT_SETUP([DISPLAY AT]) -AT_KEYWORDS([extensions]) - -AT_SKIP_IF([test "$COB_HAS_CURSES" != "yes"]) - -AT_DATA([prog.cob], [ - IDENTIFICATION DIVISION. - PROGRAM-ID. prog. - DATA DIVISION. - WORKING-STORAGE SECTION. - 01 success-flag PIC X VALUE 'Y'. - 88 success VALUE 'Y', 'y'. - - 01 screen-loc PIC 9(6) VALUE 4004. - - SCREEN SECTION. - 01 scr. - 03 VALUE 'Enter "y" if the numbers 1-3 are in a diagonal'- - ' line from line 2, column 2.'. - 03 success-field PIC X, LINE 6, REQUIRED, - USING success-flag. - - PROCEDURE DIVISION. - DISPLAY '1' AT 0202 - DISPLAY '2' AT 003003 - DISPLAY '3' AT screen-loc - DISPLAY scr - ACCEPT scr - - IF success AND COB-CRT-STATUS = 0 - GOBACK RETURNING 0 - ELSE - GOBACK RETURNING 1 - END-IF - . -]) - -AT_CHECK([$COMPILE prog.cob], [0], [], []) -MANUAL_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) - -AT_CLEANUP - - -AT_SETUP([DISPLAY LOW-VALUES (one statement)]) -AT_KEYWORDS([LOW-VALUE extensions]) - -AT_SKIP_IF([test "$COB_HAS_CURSES" != "yes"]) - -AT_DATA([prog.cob], [ - IDENTIFICATION DIVISION. - PROGRAM-ID. prog. - DATA DIVISION. - WORKING-STORAGE SECTION. - 01 success-flag PIC X VALUE 'Y'. - 88 success VALUE 'Y', 'y'. - - SCREEN SECTION. - 01 scr. - 03 LINE 1 VALUE 'Enter "y" if the word below starts at line' - & ' 3, column 3.'. - 03 LINE + 4 PIC X, REQUIRED USING success-flag. - - PROCEDURE DIVISION. - DISPLAY scr - DISPLAY LOW-VALUES AT LINE 3, COL 3; 'Hello!' - ACCEPT scr - - IF success AND COB-CRT-STATUS = 0 - GOBACK RETURNING 0 - ELSE - GOBACK RETURNING 1 - END-IF - . -]) - -AT_CHECK([$COMPILE prog.cob], [0], [], []) -MANUAL_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) - -AT_CLEANUP - - -AT_SETUP([DISPLAY LOW-VALUES (two statements)]) -AT_KEYWORDS([LOW-VALUE extensions]) - -AT_SKIP_IF([test "$COB_HAS_CURSES" != "yes"]) - -AT_DATA([prog.cob], [ - IDENTIFICATION DIVISION. - PROGRAM-ID. prog. - DATA DIVISION. - WORKING-STORAGE SECTION. - 01 success-flag PIC X VALUE 'Y'. - 88 success VALUE 'Y', 'y'. - - SCREEN SECTION. - 01 scr. - 03 LINE 1 VALUE 'Enter "y" if the word below starts at line' - & ' 3, column 3.'. - 03 LINE + 4 PIC X, REQUIRED USING success-flag. - - PROCEDURE DIVISION. - DISPLAY scr - DISPLAY LOW-VALUES AT LINE 3, COL 3 - DISPLAY 'Hello!' UPON CRT - ACCEPT scr - - IF success AND COB-CRT-STATUS = 0 - GOBACK RETURNING 0 - ELSE - GOBACK RETURNING 1 - END-IF - . -]) - -AT_CHECK([$COMPILE prog.cob], [0], [], []) -MANUAL_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) - -AT_CLEANUP - - -AT_SETUP([DISPLAY SPACES]) -AT_KEYWORDS([SPACE extensions]) - -AT_SKIP_IF([test "$COB_HAS_CURSES" != "yes"]) - -AT_DATA([prog.cob], [ - IDENTIFICATION DIVISION. - PROGRAM-ID. prog. - - DATA DIVISION. - WORKING-STORAGE SECTION. - 01 success-flag PIC X VALUE 'Y'. - 88 success VALUE 'Y', 'y'. - - SCREEN SECTION. - 01 scr-1. - 03 LINE 1 VALUE 'Enter "y" if all the text after foo in the' - & ' screen has been erased.'. - 03 LINE 3 VALUE 'Lorem ipsum dolor sit amet, consectetur ad' - & 'ipiscing elit. Curabitur dapibus dui'. - 03 LINE 4 VALUE 'vitae augue lobortis, non tempor diam tris' - & 'tique. Donec dignissim ex velit, ut'. - 03 LINE 5 VALUE 'efficitur tellus pharetra at. Curabitur at' - & ' condimentum nunc, nec accumsan'. - 03 LINE 6 VALUE 'nulla. Nulla at feugiat elit, eget condime' - & 'ntum justo. Nam lorem lectus,'. - 03 LINE 7 VALUE 'imperdiet sit amet odio eu, eleifend conse' - & 'ctetur ligula. Duis diam felis, porta'. - 03 LINE 8 VALUE 'id diam id, ultrices finibus augue. Mauris' - & ' imperdiet, dolor sed sodales porta,'. - 03 LINE 9 VALUE 'justo nunc consequat nulla, iaculis venena' - & 'tis lorem libero sit amet'. - 03 LINE 10 VALUE 'magna. Nullam pulvinar nullam.'. - 03 success-field LINE + 2, PIC X, REQUIRED, - USING success-flag. - - PROCEDURE DIVISION. - DISPLAY scr-1 - DISPLAY SPACES AT LINE 6, COL 8; 'foo' HIGHLIGHT - ACCEPT success-field - - IF success AND COB-CRT-STATUS = 0 - GOBACK RETURNING 0 - ELSE - GOBACK RETURNING 1 - END-IF - . -]) - -AT_CHECK([$COMPILE -fdisplay-special-fig-consts prog.cob], [0], [], []) -MANUAL_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) - -AT_CLEANUP - - -AT_SETUP([DISPLAY ALL X'01']) -AT_KEYWORDS([SOH extensions]) - -AT_SKIP_IF([test "$COB_HAS_CURSES" != "yes"]) - -AT_DATA([prog.cob], [ - IDENTIFICATION DIVISION. - PROGRAM-ID. prog. - - DATA DIVISION. - WORKING-STORAGE SECTION. - 01 success-flag PIC X VALUE 'Y'. - 88 success VALUE 'Y', 'y'. - - SCREEN SECTION. - 01 scr-1. - 03 LINE 1 VALUE 'Enter "y" if all the text after foo on ' - & 'that line alone has been erased.'. - 03 LINE 3 VALUE 'Lorem ipsum dolor sit amet, consectetur ad' - & 'ipiscing elit. Curabitur dapibus dui'. - 03 LINE 4 VALUE 'vitae augue lobortis, non tempor diam tris' - & 'tique. Donec dignissim ex velit, ut'. - 03 LINE 5 VALUE 'efficitur tellus pharetra at. Curabitur at' - & ' condimentum nunc, nec accumsan'. - 03 LINE 6 VALUE 'nulla. Nulla at feugiat elit, eget condime' - & 'ntum justo. Nam lorem lectus,'. - 03 LINE 7 VALUE 'imperdiet sit amet odio eu, eleifend conse' - & 'ctetur ligula. Duis diam felis, porta'. - 03 LINE 8 VALUE 'id diam id, ultrices finibus augue. Mauris' - & ' imperdiet, dolor sed sodales porta,'. - 03 LINE 9 VALUE 'justo nunc consequat nulla, iaculis venena' - & 'tis lorem libero sit amet'. - 03 LINE 10 VALUE 'magna. Nullam pulvinar nullam.'. - 03 success-field LINE + 2, PIC X, REQUIRED, - USING success-flag. - - PROCEDURE DIVISION. - DISPLAY scr-1 - DISPLAY ALL X'01', LINE 6, COLUMN 8; 'foo' HIGHLIGHT - ACCEPT success-field - - IF success AND COB-CRT-STATUS = 0 - GOBACK RETURNING 0 - ELSE - GOBACK RETURNING 1 - END-IF - . -]) - -AT_CHECK([$COMPILE -fdisplay-special-fig-consts prog.cob], [0], [], []) -MANUAL_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) - -AT_CLEANUP - - -AT_SETUP([DISPLAY ALL X'02']) -AT_KEYWORDS([STX extensions]) - -AT_SKIP_IF([test "$COB_HAS_CURSES" != "yes"]) - -AT_DATA([prog.cob], [ - IDENTIFICATION DIVISION. - PROGRAM-ID. prog. - - DATA DIVISION. - WORKING-STORAGE SECTION. - 01 success-flag PIC X VALUE 'Y'. - 88 success VALUE 'Y', 'y'. - - SCREEN SECTION. - 01 scr-1. - 03 LINE 3 VALUE 'Lorem ipsum dolor sit amet, consectetur ad' - & 'ipiscing elit. Curabitur dapibus dui'. - 03 LINE 4 VALUE 'vitae augue lobortis, non tempor diam tris' - & 'tique. Donec dignissim ex velit, ut'. - 03 LINE 5 VALUE 'efficitur tellus pharetra at. Curabitur at' - & ' condimentum nunc, nec accumsan'. - 03 LINE 6 VALUE 'nulla. Nulla at feugiat elit, eget condime' - & 'ntum justo. Nam lorem lectus,'. - 03 LINE 7 VALUE 'imperdiet sit amet odio eu, eleifend conse' - & 'ctetur ligula. Duis diam felis, porta'. - 03 LINE 8 VALUE 'id diam id, ultrices finibus augue. Mauris' - & ' imperdiet, dolor sed sodales porta,'. - 03 LINE 9 VALUE 'justo nunc consequat nulla, iaculis venena' - & 'tis lorem libero sit amet'. - 03 LINE 10 VALUE 'magna. Nullam pulvinar nullam.'. - - 01 scr-2. - 03 LINE 6 COL 8 VALUE 'foo' BLANK SCREEN, HIGHLIGHT. - 03 LINE 1 VALUE 'Enter "y" if foo is the only word below.'. - - 01 scr-3. - 03 VALUE 'Enter "y" if foo is the only word below.'. - 03 success-field COL + 2, PIC X, REQUIRED, - USING success-flag. - - PROCEDURE DIVISION. - DISPLAY scr-1 - DISPLAY ALL X'02' AT LINE 6 COL 8; 'foo' HIGHLIGHT - DISPLAY scr-3 - ACCEPT scr-3 - - IF success AND COB-CRT-STATUS = 0 - GOBACK RETURNING 0 - ELSE - GOBACK RETURNING 1 - END-IF - . -]) - -AT_CHECK([$COMPILE -fdisplay-special-fig-consts prog.cob], [0], [], []) -MANUAL_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) - -AT_CLEANUP - - -AT_SETUP([DISPLAY ALL X'07']) -AT_KEYWORDS([BELL BEEP extensions]) - -AT_SKIP_IF([test "$COB_HAS_CURSES" != "yes"]) - -AT_DATA([prog.cob], [ - IDENTIFICATION DIVISION. - PROGRAM-ID. prog. - DATA DIVISION. - WORKING-STORAGE SECTION. - 01 success-flag PIC X. - 88 success VALUE 'Y', 'y'. - - SCREEN SECTION. - 01 scr. - 03 VALUE 'Enter "y" if you heard a beep:'. - 03 success-field PIC X, COL + 2, REQUIRED, TO success-flag - FROM 'Y'. - 01 scr2. - 03 LINE 4 VALUE 'system beep may be turned off ' & - 'on this system.'. - 03 LINE 5 VALUE 'Retesting with COB_BELL=FLASH...'. - 03 LINE + 2 - VALUE 'Enter "y" if you''ve seen your terminal flash'. - 03 success-field PIC X, COL + 2, REQUIRED, TO success-flag - FROM 'Y'. - - PROCEDURE DIVISION. - DISPLAY scr - DISPLAY ALL X'07' UPON CRT - ACCEPT scr - - IF success AND COB-CRT-STATUS = 0 - GOBACK RETURNING 0 - END-IF - - SET ENVIRONMENT 'COB_BELL' TO 'FLASH' - CALL 'C$SLEEP' USING '1' - - DISPLAY scr2 - DISPLAY ALL X'07' UPON CRT - ACCEPT scr2 - - IF success AND COB-CRT-STATUS = 0 - GOBACK RETURNING 0 - ELSE - GOBACK RETURNING 1 - END-IF - . -]) - -AT_CHECK([$COMPILE -fdisplay-special-fig-consts prog.cob], [0], [], []) -MANUAL_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) - -AT_CLEANUP - - -AT_SETUP([Screen position after field display]) -AT_KEYWORDS([LINE COLUMN]) - -AT_SKIP_IF([test "$COB_HAS_CURSES" != "yes"]) - -AT_DATA([prog.cob], [ - IDENTIFICATION DIVISION. - PROGRAM-ID. prog. - DATA DIVISION. - WORKING-STORAGE SECTION. - 01 success-flag PIC X VALUE 'Y'. - 88 success VALUE 'Y', 'y'. - - SCREEN SECTION. - 01 scr. - 03 VALUE 'Enter "y" if this sentence starts at line 1,'- - ' column 1:'. - 03 success-field PIC X, COL + 2, REQUIRED, - USING success-flag. - - PROCEDURE DIVISION. - DISPLAY 'ignore this' AT LINE 4 COL 4 - DISPLAY scr - ACCEPT success-field - - IF success AND COB-CRT-STATUS = 0 - GOBACK RETURNING 0 - ELSE - GOBACK RETURNING 1 - END-IF - . -]) - -AT_CHECK([$COMPILE prog.cob], [0], [], []) -MANUAL_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) - -AT_CLEANUP - -# See section 13.17.3 - -AT_SETUP([Overridden clauses (1)]) -AT_KEYWORDS([LINE COLUMN COL]) - -AT_SKIP_IF([test "$COB_HAS_CURSES" != "yes"]) - -AT_DATA([prog.cob], [ - IDENTIFICATION DIVISION. - PROGRAM-ID. prog. - DATA DIVISION. - WORKING-STORAGE SECTION. - 01 dummy PIC X(5). - 01 success-flag PIC X VALUE 'Y'. - 88 success VALUE 'Y', 'y'. - - SCREEN SECTION. - 01 scr. - 03 VALUE 'Enter "y" if the numbers below correspond to their' - & ' column number and all on'. - 03 LINE 2 VALUE 'lines 3 and 4.'. - 03 LINE 3 VALUE '123456789'. - 03 LINE 4 VALUE ' 34'. - 03 FILLER LINE + 6. - 05 COL 3. - 07 COL 1. - 09 LINE 4 VALUE '1'. - 09 VALUE '2'. - 05 LINE + 1, COL + 2. - 07 LINE 4, COL + 1, VALUE '5'. - 03 LINE 6 PIC X, REQUIRED, USING success-flag. - - PROCEDURE DIVISION. - DISPLAY scr - ACCEPT scr - - IF success AND COB-CRT-STATUS = 0 - GOBACK RETURNING 0 - ELSE - GOBACK RETURNING 1 - END-IF - . -]) - -AT_CHECK([$COMPILE prog.cob], [0], [], []) -MANUAL_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) - -AT_CLEANUP - - -AT_SETUP([Overridden clauses (2)]) -AT_KEYWORDS([HIGHLIGHT LOWLIGHT BACKGROUND COLOR COLOUR]) - -AT_SKIP_IF([test "$COB_HAS_CURSES" != "yes"]) - -AT_DATA([prog.cob], [ - IDENTIFICATION DIVISION. - PROGRAM-ID. prog. - DATA DIVISION. - WORKING-STORAGE SECTION. - 01 dummy PIC X(5). - 01 success-flag PIC X VALUE 'Y'. - 88 success VALUE 'Y', 'y'. - - SCREEN SECTION. - 01 scr. - 03 VALUE 'Enter "y" if the word below is not dim and has' - & ' black background.'. - 03 LINE + 1, LOWLIGHT BACKGROUND-COLOR 3. - 05 HIGHLIGHT BACKGROUND-COLOR 0. - 07 VALUE 'Highlight'. - 03 LINE + 2, PIC X USING success-flag. - - PROCEDURE DIVISION. - DISPLAY scr - ACCEPT scr - - IF success AND COB-CRT-STATUS = 0 - GOBACK RETURNING 0 - ELSE - GOBACK RETURNING 1 - END-IF - . -]) - -AT_CHECK([$COMPILE prog.cob], [0], [], []) -MANUAL_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) - -AT_CLEANUP - - -AT_SETUP([AUTO]) -AT_KEYWORDS([position]) - -AT_SKIP_IF([test "$COB_HAS_CURSES" != "yes"]) - -AT_DATA([prog.cob], [ - IDENTIFICATION DIVISION. - PROGRAM-ID. prog. - DATA DIVISION. - WORKING-STORAGE SECTION. - 01 dummy PIC X(5). - 01 success-flag PIC X. - 88 success VALUE 'Y', 'y'. - - SCREEN SECTION. - 01 scr. - 03 PIC X(80) VALUE 'Enter "y" in the bottom' - & ' field if:'. - 03 LINE + 1, PIC X(80) VALUE ' * when the left field is' - & ' full, the cursor automatically moves'. - 03 LINE + 1, PIC X(80) VALUE ' to the next field.'. - 03 LINE + 1, PIC X(80) VALUE ' * this does not happen' - & ' with the other fields.'. - 03 LINE + 1, PIC X(80) VALUE ' * the fields below are' - & ' on one line and separated by a single' - & ' column.'. - - 03 test-fields LINE + 2. - 05 field-1 COL 1, PIC X(5) AUTO TO dummy. - 05 field-2 COL + 2, PIC X(5) TO dummy. - 05 field-3 COL + 2, PIC X(5) TO dummy. - 03 success-field LINE + 2, COLUMN 1; PIC X, REQUIRED - TO success-flag FROM 'Y'. - - PROCEDURE DIVISION. - DISPLAY scr - ACCEPT scr - - IF success AND COB-CRT-STATUS = 0 - GOBACK RETURNING 0 - ELSE - GOBACK RETURNING 1 - END-IF - . -]) - -AT_CHECK([$COMPILE prog.cob], [0], [], []) -MANUAL_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) - -AT_CLEANUP - - -AT_SETUP([SCREEN BACKGROUND- / FOREGROUND-COLOUR]) -AT_KEYWORDS([BACKGROUND-COLOR BACKGROUND-COLOUR FOREGROUND-COLOR -COLOR COLOUR HIGHLIGHT BLINK]) - -AT_SKIP_IF([test "$COB_HAS_CURSES" != "yes"]) - -AT_DATA([prog.cob], [ - IDENTIFICATION DIVISION. - PROGRAM-ID. prog. - DATA DIVISION. - WORKING-STORAGE SECTION. - 01 dummy PIC X(10). - 01 success-flag PIC X. - 88 success VALUE 'Y', 'y'. - - SCREEN SECTION. - 01 scr. - 03 PIC X(80) - VALUE 'Enter "y" if the text below matches the colour ' - & 'of the background/text.'. - 03 LINE + 1, COL 1, PIC X(80) - VALUE 'Note: the black text is on white background/the ' - & 'white background has black text'. - 03 LINE + 1, COL 1, PIC X(80) - VALUE 'to make the text visible.'. - - 03 LINE + 1. - 05 COL 1, PIC X(08) VALUE 'Black' FOREGROUND-COLOR 0 - BACKGROUND-COLOR 7. - 05 COL + 2, PIC X(08) VALUE 'Blue' FOREGROUND-COLOR 1. - 05 COL + 2, PIC X(08) VALUE 'Green' FOREGROUND-COLOR 2. - 05 COL + 2, PIC X(08) VALUE 'Cyan' FOREGROUND-COLOR 3. - 05 COL + 2, PIC X(08) VALUE 'Red' FOREGROUND-COLOR 4. - 05 COL + 2, PIC X(08) VALUE 'Magenta' FOREGROUND-COLOR 5. - 05 COL + 2, PIC X(15) VALUE 'Brown/Yellow' - FOREGROUND-COLOR 6. - 05 COL + 2, PIC X(08) VALUE 'White' FOREGROUND-COLOR 7. - - 03 LINE + 1. - 05 COL 1, PIC X(08) VALUE 'Black' BACKGROUND-COLOR 0 - FOREGROUND-COLOR 7. - 05 COL + 2, PIC X(08) VALUE 'Blue' BACKGROUND-COLOR 1. - 05 COL + 2, PIC X(08) VALUE 'Green' BACKGROUND-COLOR 2. - 05 COL + 2, PIC X(08) VALUE 'Cyan' BACKGROUND-COLOR 3. - 05 COL + 2, PIC X(08) VALUE 'Red' BACKGROUND-COLOR 4. - 05 COL + 2, PIC X(08) VALUE 'Magenta' BACKGROUND-COLOR 5. - 05 COL + 2, PIC X(15) VALUE 'Brown/Yellow' - BACKGROUND-COLOR 6. - 05 COL + 2, PIC X(08) VALUE 'White' BACKGROUND-COLOR 7 - FOREGROUND-COLOR 0. - - 03 LINE + 2. - 03 PIC X(80) - VALUE 'The following is the same as above, ' - & 'with "extended" attributes set;'. - 03 LINE + 1, COL 1, PIC X(80) - VALUE 'this should have the same effect as otherwise ' - & 'highlighted for the first line'. - 03 LINE + 1, COL 1, PIC X(80) - VALUE 'and blinking for the second one.'. - - 03 LINE + 1. - 05 COL 1, PIC X(08) VALUE 'Black' FOREGROUND-COLOR 8 - BACKGROUND-COLOR 0. - 05 COL + 2, PIC X(08) VALUE 'Blue' FOREGROUND-COLOR 9. - 05 COL + 2, PIC X(08) VALUE 'Green' FOREGROUND-COLOR 10. - 05 COL + 2, PIC X(08) VALUE 'Cyan' FOREGROUND-COLOR 11. - 05 COL + 2, PIC X(08) VALUE 'Red' FOREGROUND-COLOR 12. - 05 COL + 2, PIC X(08) VALUE 'Magenta' FOREGROUND-COLOR 13. - 05 COL + 2, PIC X(15) VALUE 'Brown/Yellow' - FOREGROUND-COLOR 14. - 05 COL + 2, PIC X(08) VALUE 'White' FOREGROUND-COLOR 15. - - 03 LINE + 1. - 05 COL 1, PIC X(08) VALUE 'Black' BACKGROUND-COLOR 8 - FOREGROUND-COLOR 15. - 05 COL + 2, PIC X(08) VALUE 'Blue' BACKGROUND-COLOR 9. - 05 COL + 2, PIC X(08) VALUE 'Green' BACKGROUND-COLOR 10. - 05 COL + 2, PIC X(08) VALUE 'Cyan' BACKGROUND-COLOR 11. - 05 COL + 2, PIC X(08) VALUE 'Red' BACKGROUND-COLOR 12. - 05 COL + 2, PIC X(08) VALUE 'Magenta' BACKGROUND-COLOR 13. - 05 COL + 2, PIC X(15) VALUE 'Brown/Yellow' - BACKGROUND-COLOR 14. - 05 COL + 2, PIC X(08) VALUE 'White' BACKGROUND-COLOR 15 - FOREGROUND-COLOR 8. - - 03 success-field LINE + 2, COL 1, PIC X, REQUIRED, - TO success-flag FROM 'Y'. - - PROCEDURE DIVISION. - DISPLAY scr - ACCEPT scr - - IF success AND COB-CRT-STATUS = 0 - GOBACK RETURNING 0 - ELSE - GOBACK RETURNING 1 - END-IF - . -]) - -AT_CHECK([$COMPILE prog.cob], [0], [], []) -MANUAL_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) - -AT_CLEANUP - - -AT_SETUP([SCREEN BACKGROUND- / FOREGROUND-COLOUR via COLOR]) -AT_KEYWORDS([BACKGROUND-COLOR BACKGROUND-COLOUR FOREGROUND-COLOR -COLOR COLOUR REVERSED]) - -# Currently not implemented -AT_XFAIL_IF([true]) - -AT_SKIP_IF([test "$COB_HAS_CURSES" != "yes"]) - -AT_DATA([prog.cob], [ - IDENTIFICATION DIVISION. - PROGRAM-ID. prog. - DATA DIVISION. - WORKING-STORAGE SECTION. - 01 dummy PIC X(10). - 01 success-flag PIC X. - 88 success VALUE 'Y', 'y'. - 77 CBLACK PIC 9(05) VALUE 1. - 77 CBLUE PIC 9(05) VALUE 2. - 77 CGREEN PIC 9(05) VALUE 3. - 77 CCYAN PIC 9(05) VALUE 4. - 77 CRED PIC 9(05) VALUE 5. - 77 CMAGENTA PIC 9(05) VALUE 6. - 77 CYELLOW PIC 9(05) VALUE 7. - 77 CWHITE PIC 9(05) VALUE 8. - - SCREEN SECTION. - 01 scr. - 03 PIC X(80) - VALUE 'Enter "y" if the text below matches the colour ' - & 'of the background/text.'. - 03 LINE + 1, COL 1, PIC X(80) - VALUE 'Note: the black text is on white background/the ' - & 'white background has black text'. - 03 LINE + 1, COL 1, PIC X(80) - VALUE 'to make the text visible.'. - - 03 LINE + 1. - 05 COL 1, PIC X(08) VALUE 'Black' COLOR CBLACK. - 05 COL + 2, PIC X(08) VALUE 'Blue' COLOR CBLUE. - 05 COL + 2, PIC X(08) VALUE 'Green' COLOR CGREEN. - 05 COL + 2, PIC X(08) VALUE 'Cyan' COLOR CCYAN. - 05 COL + 2, PIC X(08) VALUE 'Red' COLOR CRED. - 05 COL + 2, PIC X(08) VALUE 'Magenta' COLOR CMAGENTA. - 05 COL + 2, PIC X(15) VALUE 'Brown/Yellow' - COLOR CYELLOW. - 05 COL + 2, PIC X(08) VALUE 'White' COLOR CWHITE. - - 01 scr2. - 03 LINE 5. - 05 COL 1, PIC X(08) VALUE 'Black' BACKGROUND-COLOR 0 - FOREGROUND-COLOR 7. - 05 COL + 2, PIC X(08) VALUE 'Blue' BACKGROUND-COLOR 1. - 05 COL + 2, PIC X(08) VALUE 'Green' BACKGROUND-COLOR 2. - 05 COL + 2, PIC X(08) VALUE 'Cyan' BACKGROUND-COLOR 3. - 05 COL + 2, PIC X(08) VALUE 'Red' BACKGROUND-COLOR 4. - 05 COL + 2, PIC X(08) VALUE 'Magenta' BACKGROUND-COLOR 5. - 05 COL + 2, PIC X(15) VALUE 'Brown/Yellow' - BACKGROUND-COLOR 6. - 05 COL + 2, PIC X(08) VALUE 'White' BACKGROUND-COLOR 7 - FOREGROUND-COLOR 0. - - 03 success-field LINE + 2, COL 1, PIC X, REQUIRED, - TO success-flag FROM 'Y'. - - PROCEDURE DIVISION. - ADD 256 TO CBLACK - DISPLAY scr - ADD 1024 TO CBLACK, CBLUE, CGREEN, CCYAN, - CRED, CMAGENTA, CYELLOW, CWHITE - DISPLAY scr2 - ACCEPT scr - - IF success AND COB-CRT-STATUS = 0 - GOBACK RETURNING 0 - ELSE - GOBACK RETURNING 1 - END-IF - . -]) - -AT_CHECK([$COMPILE prog.cob], [0], [], []) -MANUAL_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) - -AT_CLEANUP - - -AT_SETUP([field BACKGROUND- / FOREGROUND-COLOUR]) -AT_KEYWORDS([BACKGROUND-COLOR BACKGROUND-COLOUR FOREGROUND-COLOR -COLOR COLOUR HIGHLIGHT BLINK]) - -AT_SKIP_IF([test "$COB_HAS_CURSES" != "yes"]) - -AT_DATA([prog.cob], [ - IDENTIFICATION DIVISION. - PROGRAM-ID. prog. - DATA DIVISION. - WORKING-STORAGE SECTION. - 01 dummy PIC X(10). - 01 success-flag PIC X. - 88 success VALUE 'Y', 'y'. - - SCREEN SECTION. - 01 scr. - 03 PIC X(80) - VALUE 'Enter "y" if the text below matches the colour ' - & 'of the background/text.'. - 03 LINE + 1, COL 1, PIC X(80) - VALUE 'Note: the black text is on white background/the ' - & 'white background has black text'. - 03 LINE + 1, COL 1, PIC X(80) - VALUE 'to make the text visible.'. - - 03 LINE + 1. - 05 COL 1, PIC X(08) VALUE 'Black' FOREGROUND-COLOR 0 - BACKGROUND-COLOR 7. - 05 COL + 2, PIC X(08) VALUE 'Blue' FOREGROUND-COLOR 1. - 05 COL + 2, PIC X(08) VALUE 'Green' FOREGROUND-COLOR 2. - 05 COL + 2, PIC X(08) VALUE 'Cyan' FOREGROUND-COLOR 3. - 05 COL + 2, PIC X(08) VALUE 'Red' FOREGROUND-COLOR 4. - 05 COL + 2, PIC X(08) VALUE 'Magenta' FOREGROUND-COLOR 5. - 05 COL + 2, PIC X(15) VALUE 'Brown/Yellow' - FOREGROUND-COLOR 6. - 05 COL + 2, PIC X(08) VALUE 'White' FOREGROUND-COLOR 7. - - 03 LINE + 1. - 05 COL 1, PIC X(08) VALUE 'Black' BACKGROUND-COLOR 0 - FOREGROUND-COLOR 7. - 05 COL + 2, PIC X(08) VALUE 'Blue' BACKGROUND-COLOR 1. - 05 COL + 2, PIC X(08) VALUE 'Green' BACKGROUND-COLOR 2. - 05 COL + 2, PIC X(08) VALUE 'Cyan' BACKGROUND-COLOR 3. - 05 COL + 2, PIC X(08) VALUE 'Red' BACKGROUND-COLOR 4. - 05 COL + 2, PIC X(08) VALUE 'Magenta' BACKGROUND-COLOR 5. - 05 COL + 2, PIC X(15) VALUE 'Brown/Yellow' - BACKGROUND-COLOR 6. - 05 COL + 2, PIC X(08) VALUE 'White' BACKGROUND-COLOR 7 - FOREGROUND-COLOR 0. - - 03 LINE + 2. - 03 PIC X(80) - VALUE 'The following is the same as above, ' - & 'with "extended" attributes set;'. - 03 LINE + 1, COL 1, PIC X(80) - VALUE 'this should have the same effect as otherwise ' - & 'highlighted for the first line'. - 03 LINE + 1, COL 1, PIC X(80) - VALUE 'and blinking for the second one.'. - - 03 LINE + 1. - 05 COL 1, PIC X(08) VALUE 'Black' FOREGROUND-COLOR 8 - BACKGROUND-COLOR 0. - 05 COL + 2, PIC X(08) VALUE 'Blue' FOREGROUND-COLOR 9. - 05 COL + 2, PIC X(08) VALUE 'Green' FOREGROUND-COLOR 10. - 05 COL + 2, PIC X(08) VALUE 'Cyan' FOREGROUND-COLOR 11. - 05 COL + 2, PIC X(08) VALUE 'Red' FOREGROUND-COLOR 12. - 05 COL + 2, PIC X(08) VALUE 'Magenta' FOREGROUND-COLOR 13. - 05 COL + 2, PIC X(15) VALUE 'Brown/Yellow' - FOREGROUND-COLOR 14. - 05 COL + 2, PIC X(08) VALUE 'White' FOREGROUND-COLOR 15. - - 03 LINE + 1. - 05 COL 1, PIC X(08) VALUE 'Black' BACKGROUND-COLOR 8 - FOREGROUND-COLOR 15. - 05 COL + 2, PIC X(08) VALUE 'Blue' BACKGROUND-COLOR 9. - 05 COL + 2, PIC X(08) VALUE 'Green' BACKGROUND-COLOR 10. - 05 COL + 2, PIC X(08) VALUE 'Cyan' BACKGROUND-COLOR 11. - 05 COL + 2, PIC X(08) VALUE 'Red' BACKGROUND-COLOR 12. - 05 COL + 2, PIC X(08) VALUE 'Magenta' BACKGROUND-COLOR 13. - 05 COL + 2, PIC X(15) VALUE 'Brown/Yellow' - BACKGROUND-COLOR 14. - 05 COL + 2, PIC X(08) VALUE 'White' BACKGROUND-COLOR 15 - FOREGROUND-COLOR 8. - - 03 success-field LINE + 2, COL 1, PIC X, REQUIRED, - TO success-flag FROM 'Y'. - - PROCEDURE DIVISION. - DISPLAY scr - ACCEPT scr - - IF success AND COB-CRT-STATUS = 0 - GOBACK RETURNING 0 - ELSE - GOBACK RETURNING 1 - END-IF - . -]) - -AT_CHECK([$COMPILE prog.cob], [0], [], []) -MANUAL_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) - -AT_CLEANUP - - -AT_SETUP([field BACKGROUND- / FOREGROUND-COLOUR via COLOR]) -AT_KEYWORDS([BACKGROUND-COLOR BACKGROUND-COLOUR FOREGROUND-COLOR -COLOR COLOUR REVERSED HIGHLIGHT BLINK]) - -AT_SKIP_IF([test "$COB_HAS_CURSES" != "yes"]) - -AT_DATA([prog.cob], [ - IDENTIFICATION DIVISION. - PROGRAM-ID. prog. - DATA DIVISION. - WORKING-STORAGE SECTION. - 01 success-flag PIC X VALUE 'Y'. - 88 success VALUE 'Y', 'y'. - - 77 CBLACK PIC 9(05) COMP-5 VALUE 1. - 77 CBLUE PIC 9(05) COMP-5 VALUE 2. - 77 CGREEN PIC 9(05) COMP-5 VALUE 3. - 77 CCYAN PIC 9(05) COMP-5 VALUE 4. - 77 CRED PIC 9(05) COMP-5 VALUE 5. - 77 CMAGENTA PIC 9(05) COMP-5 VALUE 6. - 77 CYELLOW PIC 9(05) COMP-5 VALUE 7. - 77 CWHITE PIC 9(05) COMP-5 VALUE 8. - - 77 LIN PIC 99 COMP-5. - - 01 scr1 PIC X(80) - VALUE 'Enter "y" if the text below matches the colour ' - & 'of the background/text.'. - 01 scr2 PIC X(80) - VALUE 'Note: the black text is on white background/the ' - & 'white background has black text'. - 01 scr3 PIC X(80) - VALUE 'to make the text visible.'. - 01 scr8 PIC X(80) - VALUE 'following lines should be identical but ' - & 'highlighted for the first line'. - 01 scr9 PIC X(80) - VALUE 'and blinking for the second one.'. - - 01 scrblack PIC X(08) VALUE 'Black'. - 01 scrblue PIC X(08) VALUE 'Blue'. - 01 scrgreen PIC X(08) VALUE 'Green'. - 01 scrcyan PIC X(08) VALUE 'Cyan'. - 01 scrred PIC X(08) VALUE 'Red'. - 01 scrmaggy PIC X(08) VALUE 'Magenta'. - 01 scryell PIC X(14) VALUE 'Brown/Yellow'. - 01 scrwhite PIC X(08) VALUE 'White'. - - PROCEDURE DIVISION. - testme. - ADD 256 TO CBLACK - DISPLAY scr1 AT 0102 - DISPLAY scr2 AT 0202 - DISPLAY scr3 AT 0303 - MOVE 5 TO LIN - PERFORM dspcol - ADD 1024 TO CBLACK, CBLUE, CGREEN, CCYAN, - CRED, CMAGENTA, CYELLOW, CWHITE - MOVE 6 TO LIN - PERFORM dspcol - SUBTRACT 1024 FROM CBLACK, CBLUE, CGREEN, CCYAN, - CRED, CMAGENTA, CYELLOW, CWHITE - * - DISPLAY scr8 AT 0802 - DISPLAY scr9 AT 0903 - ADD 4096 TO CBLACK, CBLUE, CGREEN, CCYAN, - CRED, CMAGENTA, CYELLOW, CWHITE - MOVE 11 TO LIN - PERFORM dspcol - SUBTRACT 4096 FROM CBLACK, CBLUE, CGREEN, CCYAN, - CRED, CMAGENTA, CYELLOW, CWHITE - ADD 1024, 16384 TO CBLACK, CBLUE, CGREEN, CCYAN, - CRED, CMAGENTA, CYELLOW, CWHITE - MOVE 12 TO LIN - PERFORM dspcol - * - ACCEPT success-flag AT 1401 UPDATE REQUIRED - - IF success AND COB-CRT-STATUS = 0 - GOBACK RETURNING 0 - ELSE - GOBACK RETURNING 1. - - dspcol. - DISPLAY scrblack LINE LIN COL 1, COLOR CBLACK. - DISPLAY scrblue LINE LIN COL 11, COLOR CBLUE. - DISPLAY scrgreen LINE LIN COL 21, COLOR CGREEN. - DISPLAY scrcyan LINE LIN COL 31, COLOR CCYAN. - DISPLAY scrred LINE LIN COL 41, COLOR CRED. - DISPLAY scrmaggy LINE LIN COL 51, COLOR CMAGENTA. - DISPLAY scryell LINE LIN COL 61, COLOR CYELLOW. - DISPLAY scrwhite LINE LIN COL 77, COLOR CWHITE. -]) - -AT_CHECK([$COMPILE prog.cob], [0], [], []) -MANUAL_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) - -AT_CLEANUP - - -AT_SETUP([field BACKGROUND- / FOREGROUND-COLOUR via CONTROL]) -AT_KEYWORDS([screen DISPLAY REVERSED HIGHLIGHT BLINK COLOR -BACKGROUND-COLOR BACKGROUND-COLOUR FOREGROUND-COLOR COLOUR]) - -AT_SKIP_IF([test "$COB_HAS_CURSES" != "yes"]) - -AT_DATA([prog.cob], [[ - IDENTIFICATION DIVISION. - PROGRAM-ID. prog. - DATA DIVISION. - WORKING-STORAGE SECTION. - 01 success-flag PIC X VALUE 'Y'. - 88 success VALUE 'Y', 'y'. - - * ACU: "=", names only - 77 CBLACK PIC X(99) VALUE "FCOLOR=BLACK, " - & "BCOLOR=WHITE,". - 77 CBLUE PIC X(99) VALUE "FCOLOR=BLUE , " - & "BCOLOR=BLACK,". - * MF: "IS" or "=" or " ", also extended color numbers - 77 CGREEN PIC X(99) VALUE "FCOLOR IS GREEN, " - & "BCOLOR BLACK,". - 77 CCYAN PIC X(99) VALUE "FCOLOR =CYAN, " - & "BCOLOR= BLACK, ". - 77 CRED PIC X(99) VALUE "FCOLOR=RED " - & "BCOLOR=BLACK, ". - 77 CMAGENTA PIC X(99) VALUE "FCOLOR=MAGENTA, " - & "BCOLOR=BLACK,". - 77 CYELLOW PIC X(99) VALUE "FCOLOR = 6, " - & "BCOLOR=BLACK,". - 77 CWHITE PIC X(99) VALUE "FCOLOR=WHITE, " - & "BCOLOR=BLACK, ". - - 77 LIN PIC 99 COMP-5. - - 01 scr1 PIC X(75) - VALUE 'Enter "y" if the text below matches the colour ' - & 'of the background/text.'. - 01 scr2 PIC X(75) - VALUE 'Note: the black text is on white background/the ' - & 'white background has black'. - 01 scr3 PIC X(75) - VALUE 'text to make the text visible.' - & ' [This text *may* has "surrounding lines".]'. - 01 scr8 PIC X(75) - VALUE 'following lines should be identical but ' - & 'highlighted for the first line'. - 01 scr9 PIC X(75) - VALUE 'and blinking for the second one.'. - - 01 scrblack PIC X(08) VALUE 'Black'. - 01 scrblue PIC X(08) VALUE 'Blue'. - 01 scrgreen PIC X(08) VALUE 'Green'. - 01 scrcyan PIC X(08) VALUE 'Cyan'. - 01 scrred PIC X(08) VALUE 'Red'. - 01 scrmaggy PIC X(08) VALUE 'Magenta'. - 01 scryell PIC X(14) VALUE 'Brown/Yellow'. - 01 scrwhite PIC X(08) VALUE 'White'. - - PROCEDURE DIVISION. - testme. - MOVE 2 TO LIN - DISPLAY scr1 ( 1:1) AT LINE LIN COL 2 - CONTROL "LEFTLINE OVERLINE" - DISPLAY scr1 ( 2:) AT LINE LIN COL 2 + 1 - CONTROL "OVERLINE" - DISPLAY scr1 (75:) AT LINE LIN COL 2 + 75 - CONTROL "OVERLINE RIGHTLINE" - ADD 1 TO LIN - DISPLAY scr2 ( 1:1) AT LINE LIN COL 2 - CONTROL "LEFTLINE" - DISPLAY scr2 ( 2:) AT LINE LIN COL 2 + 1 - DISPLAY scr2 (75:) AT LINE LIN COL 2 + 75 - CONTROL "RIGHTLINE" - ADD 1 TO LIN - DISPLAY scr3 ( 1:1) AT LINE LIN COL 2 - CONTROL "LEFTLINE UNDERLINE" - DISPLAY scr3 ( 2:) AT LINE LIN COL 2 + 1 - CONTROL "UNDERLINE" - DISPLAY scr3 (75:) AT LINE LIN COL 2 + 75 - CONTROL "UNDERLINE RIGHTLINE" - * - ADD 2 TO LIN - PERFORM dspcol - MOVE "REVERSE," TO - CBLACK (40:), CBLUE (40:), CGREEN (40:), CCYAN (40:), - CRED (40:), CMAGENTA (40:), CYELLOW (40:), CWHITE (40:) - ADD 1 TO LIN - PERFORM dspcol - * - INSPECT CRED REPLACING ALL "=" BY " " - ADD 2 TO LIN - DISPLAY scr8 AT LINE LIN COL 2 - ADD 1 TO LIN - DISPLAY scr9 AT LINE LIN COL 2 - * - MOVE "HIGHLIGHT,NO REVERSE" TO - CBLACK (50:), CBLUE (50:), CGREEN (50:), CCYAN (50:), - CRED (50:), CMAGENTA (50:), CYELLOW (50:), CWHITE (50:) - ADD 1 TO LIN - PERFORM dspcol - MOVE "NO HIGH, BLINK" TO - CBLACK (60:), CBLUE (60:), CGREEN (60:), CCYAN (60:), - CRED (60:), CMAGENTA (60:), CYELLOW (60:), CWHITE (60:) - MOVE 12 TO LIN - PERFORM dspcol - * - ACCEPT success-flag AT 1801 UPDATE REQUIRED - - IF success AND COB-CRT-STATUS = 0 - GOBACK RETURNING 0 - ELSE - GOBACK RETURNING 1. - - dspcol. - DISPLAY scrblack LINE LIN COL 1, CONTROL CBLACK. - DISPLAY scrblue LINE LIN COL 10, CONTROL CBLUE. - DISPLAY scrgreen LINE LIN COL 19, CONTROL CGREEN. - DISPLAY scrcyan LINE LIN COL 28, CONTROL CCYAN. - DISPLAY scrred LINE LIN COL 37, CONTROL CRED. - DISPLAY scrmaggy LINE LIN COL 46, CONTROL CMAGENTA. - DISPLAY scryell LINE LIN COL 55, CONTROL CYELLOW. - DISPLAY scrwhite LINE LIN COL 70, CONTROL CWHITE. -]]) - -AT_CHECK([$COMPILE prog.cob], [0], [], []) -MANUAL_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) - -AT_CLEANUP - - -AT_SETUP([line draw characters via CONTROL GRAPHICS]) -AT_KEYWORDS([screen DISPLAY]) - -AT_SKIP_IF([test "$COB_HAS_CURSES" != "yes"]) - -AT_DATA([prog.cob], [[ - IDENTIFICATION DIVISION. - PROGRAM-ID. prog. - DATA DIVISION. - WORKING-STORAGE SECTION. - 01 success-flag PIC X VALUE 'Y'. - 88 success VALUE 'Y', 'y'. - - 77 LIN-START PIC 99 COMP-5. - 77 LIN PIC 99 COMP-5. - - 01 scr1 PIC X(75) - VALUE 'Enter "y" if you see line draw characters. ' - & 'The first set (single/double)'. - 01 scr2 PIC X(75) - VALUE 'uses HIGHLIGHT, the second uses ' - & 'LOWLIGHT, BLINK and MAGENTA.'. - - 01 graphcontrol PIC X(50) VALUE 'HIGH, GRAPHICS'. - - PROCEDURE DIVISION. - testme. - MOVE 2 TO LIN - DISPLAY scr1 AT LINE LIN COL 2 - ADD 1 TO LIN - DISPLAY scr2 AT LINE LIN COL 2 - * - MOVE 5 TO LIN-START - PERFORM dspcol - MOVE 12 TO LIN-START - MOVE "LOW BLINK FCOLOR=MAGENTA GRAPHICS" TO graphcontrol - PERFORM dspcol - * - ACCEPT success-flag AT 1801 UPDATE REQUIRED - - IF success AND COB-CRT-STATUS = 0 - GOBACK RETURNING 0 - ELSE - GOBACK RETURNING 1. - - dspcol. - * Single-line graphics - MOVE LIN-START TO LIN - DISPLAY "lqqqqwqqqqk" LINE LIN COL 05, CONTROL graphcontrol. - ADD 1 TO LIN - DISPLAY "x x x" LINE LIN COL 05, CONTROL graphcontrol. - ADD 1 TO LIN - DISPLAY "tqqqqnqqqqu" LINE LIN COL 05, CONTROL graphcontrol. - ADD 1 TO LIN - DISPLAY "x x x" LINE LIN COL 05, CONTROL graphcontrol. - ADD 1 TO LIN - DISPLAY "mqqqqvqqqqj" LINE LIN COL 05, CONTROL graphcontrol. - ADD 1 TO LIN - * Double-line graphics - MOVE LIN-START TO LIN - DISPLAY "LQQQQWQQQQK" LINE LIN COL 20, CONTROL graphcontrol. - ADD 1 TO LIN - DISPLAY "X X X" LINE LIN COL 20, CONTROL graphcontrol. - ADD 1 TO LIN - DISPLAY "TQQQQNQQQQU" LINE LIN COL 20, CONTROL graphcontrol. - ADD 1 TO LIN - DISPLAY "X X X" LINE LIN COL 20, CONTROL graphcontrol. - ADD 1 TO LIN - DISPLAY "MQQQQVQQQQJ" LINE LIN COL 20, CONTROL graphcontrol. -]]) - -AT_CHECK([$COMPILE prog.cob], [0], [], []) -MANUAL_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) - -AT_CLEANUP - - -AT_SETUP([BEEP]) -AT_KEYWORDS([BELL FLASH]) - -AT_SKIP_IF([test "$COB_HAS_CURSES" != "yes"]) - -AT_DATA([prog.cob], [ - IDENTIFICATION DIVISION. - PROGRAM-ID. prog. - DATA DIVISION. - WORKING-STORAGE SECTION. - 01 success-flag PIC X. - 88 success VALUE 'Y', 'y'. - - SCREEN SECTION. - 01 scr. - 03 BELL. - 03 VALUE 'Enter "y" if you heard a beep:'. - 03 success-field PIC X, COL + 2, REQUIRED, TO success-flag - FROM 'Y'. - 01 scr2. - 03 LINE 4 VALUE 'system beep may be turned off ' & - 'on this system.'. - 03 LINE 5 VALUE 'Retesting with COB_BELL=FLASH...'. - 03 LINE + 2, - VALUE 'Enter "y" if you''ve seen your terminal flash'. - 03 success-field PIC X, COL + 2, REQUIRED, TO success-flag - FROM 'Y'. - - PROCEDURE DIVISION. - DISPLAY scr - ACCEPT scr - - IF success AND COB-CRT-STATUS = 0 - GOBACK RETURNING 0 - END-IF - - SET ENVIRONMENT 'COB_BELL' TO 'FLASH' - CALL 'C$SLEEP' USING '1' - - DISPLAY scr2 - DISPLAY ALL X'07' UPON CRT - ACCEPT scr2 - - IF success AND COB-CRT-STATUS = 0 - GOBACK RETURNING 0 - ELSE - GOBACK RETURNING 1 - END-IF - . -]) - -AT_CHECK([$COMPILE prog.cob], [0], [], []) -MANUAL_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) - -AT_CLEANUP - - -AT_SETUP([BLANK LINE]) -AT_KEYWORDS([screen]) - -AT_SKIP_IF([test "$COB_HAS_CURSES" != "yes"]) - -AT_DATA([prog.cob], [ - IDENTIFICATION DIVISION. - PROGRAM-ID. prog. - - DATA DIVISION. - WORKING-STORAGE SECTION. - 01 success-flag PIC X VALUE 'Y'. - 88 success VALUE 'Y', 'y'. - - SCREEN SECTION. - 01 scr-1. - 03 LINE 3 VALUE 'Lorem ipsum dolor sit amet, consectetur ad' - & 'ipiscing elit. Curabitur dapibus dui'. - 03 LINE 4 VALUE 'vitae augue lobortis, non tempor diam tris' - & 'tique. Donec dignissim ex velit, ut'. - 03 LINE 5 VALUE 'efficitur tellus pharetra at. Curabitur at' - & ' condimentum nunc, nec accumsan'. - 03 LINE 6 VALUE 'nulla. Nulla at feugiat elit, eget condime' - & 'ntum justo. Nam lorem lectus,'. - 03 LINE 7 VALUE 'imperdiet sit amet odio eu, eleifend conse' - & 'ctetur ligula. Duis diam felis, porta'. - 03 LINE 8 VALUE 'id diam id, ultrices finibus augue. Mauris' - & ' imperdiet, dolor sed sodales porta,'. - 03 LINE 9 VALUE 'justo nunc consequat nulla, iaculis venena' - & 'tis lorem libero sit amet'. - 03 LINE 10 VALUE 'magna. Nullam pulvinar nullam.'. - 03 success-field LINE + 2, PIC X, REQUIRED, - USING success-flag. - - 01 scr-2. - 03 LINE 6 COL 8 VALUE 'foo' BLANK LINE, HIGHLIGHT. - 03 LINE 1 VALUE 'Enter "y" if foo is the only word on one' - & ' line.'. - - PROCEDURE DIVISION. - DISPLAY scr-1 - DISPLAY scr-2 - ACCEPT success-field - - IF success AND COB-CRT-STATUS = 0 - GOBACK RETURNING 0 - ELSE - GOBACK RETURNING 1 - END-IF - . -]) - -AT_CHECK([$COMPILE prog.cob], [0], [], []) -MANUAL_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) - -AT_CLEANUP - - -AT_SETUP([BLANK SCREEN]) -AT_KEYWORDS([screen]) - -AT_SKIP_IF([test "$COB_HAS_CURSES" != "yes"]) - -AT_DATA([prog.cob], [ - IDENTIFICATION DIVISION. - PROGRAM-ID. prog. - - DATA DIVISION. - WORKING-STORAGE SECTION. - 01 success-flag PIC X VALUE 'Y'. - 88 success VALUE 'Y', 'y'. - - SCREEN SECTION. - 01 scr-1. - 03 LINE 3 VALUE 'Lorem ipsum dolor sit amet, consectetur ad' - & 'ipiscing elit. Curabitur dapibus dui'. - 03 LINE 4 VALUE 'vitae augue lobortis, non tempor diam tris' - & 'tique. Donec dignissim ex velit, ut'. - 03 LINE 5 VALUE 'efficitur tellus pharetra at. Curabitur at' - & ' condimentum nunc, nec accumsan'. - 03 LINE 6 VALUE 'nulla. Nulla at feugiat elit, eget condime' - & 'ntum justo. Nam lorem lectus,'. - 03 LINE 7 VALUE 'imperdiet sit amet odio eu, eleifend conse' - & 'ctetur ligula. Duis diam felis, porta'. - 03 LINE 8 VALUE 'id diam id, ultrices finibus augue. Mauris' - & ' imperdiet, dolor sed sodales porta,'. - 03 LINE 9 VALUE 'justo nunc consequat nulla, iaculis venena' - & 'tis lorem libero sit amet'. - 03 LINE 10 VALUE 'magna. Nullam pulvinar nullam.'. - 03 success-field LINE + 2, PIC X, REQUIRED, - USING success-flag. - - 01 scr-2. - 03 LINE 6 COL 8 VALUE 'foo' BLANK SCREEN, HIGHLIGHT. - 03 LINE 1 VALUE 'Enter "y" if foo is the only word below.'. - - PROCEDURE DIVISION. - DISPLAY scr-1 - DISPLAY scr-2 - ACCEPT success-field - - IF success AND COB-CRT-STATUS = 0 - GOBACK RETURNING 0 - ELSE - GOBACK RETURNING 1 - END-IF - . -]) - -AT_CHECK([$COMPILE prog.cob], [0], [], []) -MANUAL_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) - -AT_CLEANUP - - -AT_SETUP([BLANK ignored in ACCEPT]) -AT_KEYWORDS([screen]) - -AT_SKIP_IF([test "$COB_HAS_CURSES" != "yes"]) - -AT_DATA([prog.cob], [ - IDENTIFICATION DIVISION. - PROGRAM-ID. prog. - - DATA DIVISION. - WORKING-STORAGE SECTION. - 01 success-flag PIC X VALUE 'Y'. - 88 success VALUE 'Y', 'y'. - - SCREEN SECTION. - 01 scr. - 03 LINE 1 VALUE 'Enter "y" if you can see lorem ipsum ' - & 'filler text.'. - 03 LINE 3 COL 3 VALUE 'Lorem ipsum dolor sit amet,' - & ' consectetur ad ipiscing elit.'. - - 01 success-scr. - 03 LINE 3, BLANK LINE, PIC X, REQUIRED, USING success-flag. - - PROCEDURE DIVISION. - DISPLAY scr - ACCEPT success-scr - - IF success AND COB-CRT-STATUS = 0 - GOBACK RETURNING 0 - ELSE - GOBACK RETURNING 1 - END-IF - . -]) - -AT_CHECK([$COMPILE prog.cob], [0], [], []) -MANUAL_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) - -AT_CLEANUP - - -AT_SETUP([BLINK]) -AT_KEYWORDS([screen]) - -AT_SKIP_IF([test "$COB_HAS_CURSES" != "yes"]) - -AT_DATA([prog.cob], [ - IDENTIFICATION DIVISION. - PROGRAM-ID. prog. - DATA DIVISION. - WORKING-STORAGE SECTION. - 01 success-flag PIC X VALUE 'Y'. - 88 success VALUE 'Y', 'y'. - - SCREEN SECTION. - 01 scr. - 03 PIC X(80) - VALUE 'Enter "y" if the string below is blinking:'. - 03 LINE + 1, PIC X(10) VALUE 'Blink' BLINK. - 03 success-field LINE + 2, PIC X, REQUIRED, - USING success-flag. - - PROCEDURE DIVISION. - DISPLAY scr - ACCEPT scr - - IF success AND COB-CRT-STATUS = 0 - GOBACK RETURNING 0 - ELSE - GOBACK RETURNING 1 - END-IF - . -]) - -AT_CHECK([$COMPILE prog.cob], [0], [], []) -MANUAL_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) - -AT_CLEANUP - - -AT_SETUP([ERASE EOS]) -AT_KEYWORDS([screen]) - -AT_SKIP_IF([test "$COB_HAS_CURSES" != "yes"]) - -AT_DATA([prog.cob], [ - IDENTIFICATION DIVISION. - PROGRAM-ID. prog. - - DATA DIVISION. - WORKING-STORAGE SECTION. - 01 success-flag PIC X VALUE 'Y'. - 88 success VALUE 'Y', 'y'. - - SCREEN SECTION. - 01 scr-1. - 03 LINE 1 VALUE 'Enter "y" if all the text after foo in the' - & ' screen has been erased.'. - 03 LINE 3 VALUE 'Lorem ipsum dolor sit amet, consectetur ad' - & 'ipiscing elit. Curabitur dapibus dui'. - 03 LINE 4 VALUE 'vitae augue lobortis, non tempor diam tris' - & 'tique. Donec dignissim ex velit, ut'. - 03 LINE 5 VALUE 'efficitur tellus pharetra at. Curabitur at' - & ' condimentum nunc, nec accumsan'. - 03 LINE 6 VALUE 'nulla. Nulla at feugiat elit, eget condime' - & 'ntum justo. Nam lorem lectus,'. - 03 LINE 7 VALUE 'imperdiet sit amet odio eu, eleifend conse' - & 'ctetur ligula. Duis diam felis, porta'. - 03 LINE 8 VALUE 'id diam id, ultrices finibus augue. Mauris' - & ' imperdiet, dolor sed sodales porta,'. - 03 LINE 9 VALUE 'justo nunc consequat nulla, iaculis venena' - & 'tis lorem libero sit amet'. - 03 LINE 10 VALUE 'magna. Nullam pulvinar nullam.'. - 03 success-field LINE + 2, PIC X, REQUIRED, - USING success-flag. - - 01 scr-2. - 03 LINE 6 COL 8 VALUE 'foo' ERASE EOS, HIGHLIGHT. - - PROCEDURE DIVISION. - DISPLAY scr-1 - DISPLAY scr-2 - ACCEPT success-field - - IF success AND COB-CRT-STATUS = 0 - GOBACK RETURNING 0 - ELSE - GOBACK RETURNING 1 - END-IF - . -]) - -AT_CHECK([$COMPILE prog.cob], [0], [], []) -MANUAL_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) - -AT_CLEANUP - - -AT_SETUP([ERASE EOL]) -AT_KEYWORDS([screen]) - -AT_SKIP_IF([test "$COB_HAS_CURSES" != "yes"]) - -AT_DATA([prog.cob], [ - IDENTIFICATION DIVISION. - PROGRAM-ID. prog. - - DATA DIVISION. - WORKING-STORAGE SECTION. - 01 success-flag PIC X VALUE 'Y'. - 88 success VALUE 'Y', 'y'. - - SCREEN SECTION. - 01 scr-1. - 03 LINE 1 VALUE 'Enter "y" if all the text after foo on ' - & 'that line alone has been erased.'. - 03 LINE 3 VALUE 'Lorem ipsum dolor sit amet, consectetur ad' - & 'ipiscing elit. Curabitur dapibus dui'. - 03 LINE 4 VALUE 'vitae augue lobortis, non tempor diam tris' - & 'tique. Donec dignissim ex velit, ut'. - 03 LINE 5 VALUE 'efficitur tellus pharetra at. Curabitur at' - & ' condimentum nunc, nec accumsan'. - 03 LINE 6 VALUE 'nulla. Nulla at feugiat elit, eget condime' - & 'ntum justo. Nam lorem lectus,'. - 03 LINE 7 VALUE 'imperdiet sit amet odio eu, eleifend conse' - & 'ctetur ligula. Duis diam felis, porta'. - 03 LINE 8 VALUE 'id diam id, ultrices finibus augue. Mauris' - & ' imperdiet, dolor sed sodales porta,'. - 03 LINE 9 VALUE 'justo nunc consequat nulla, iaculis venena' - & 'tis lorem libero sit amet'. - 03 LINE 10 VALUE 'magna. Nullam pulvinar nullam.'. - 03 success-field LINE + 2, PIC X, REQUIRED, - USING success-flag. - - 01 scr-2. - 03 LINE 6 COL 8 VALUE 'foo' ERASE EOL, HIGHLIGHT. - - PROCEDURE DIVISION. - DISPLAY scr-1 - DISPLAY scr-2 - ACCEPT success-field - - IF success AND COB-CRT-STATUS = 0 - GOBACK RETURNING 0 - ELSE - GOBACK RETURNING 1 - END-IF - . -]) - -AT_CHECK([$COMPILE prog.cob], [0], [], []) -MANUAL_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) - -AT_CLEANUP - - -AT_SETUP([ERASE ignored in ACCEPT]) -AT_KEYWORDS([EOS]) - -AT_SKIP_IF([test "$COB_HAS_CURSES" != "yes"]) - -AT_DATA([prog.cob], [ - IDENTIFICATION DIVISION. - PROGRAM-ID. prog. - - DATA DIVISION. - WORKING-STORAGE SECTION. - 01 success-flag PIC X VALUE 'Y'. - 88 success VALUE 'Y', 'y'. - - SCREEN SECTION. - 01 scr. - 03 LINE 1 VALUE 'Enter "y" if you can see lorem ipsum ' - & 'filler text.'. - 03 LINE 3 VALUE 'Lorem ipsum dolor sit amet, consectetur ad' - & 'ipiscing elit. Curabitur dapibus dui'. - 03 LINE 4 VALUE 'vitae augue lobortis, non tempor diam tris' - & 'tique. Donec dignissim ex velit, ut'. - 03 LINE 5 VALUE 'efficitur tellus pharetra at. Curabitur at' - & ' condimentum nunc, nec accumsan'. - 03 LINE 6 VALUE 'nulla. Nulla at feugiat elit, eget condime' - & 'ntum justo. Nam lorem lectus,'. - 03 LINE 7 VALUE 'imperdiet sit amet odio eu, eleifend conse' - & 'ctetur ligula. Duis diam felis, porta'. - 03 LINE 8 VALUE 'id diam id, ultrices finibus augue. Mauris' - & ' imperdiet, dolor sed sodales porta,'. - 03 LINE 9 VALUE 'justo nunc consequat nulla, iaculis venena' - & 'tis lorem libero sit amet'. - 03 LINE 10 VALUE 'magna. Nullam pulvinar nullam.'. - 03 LINE 3 ERASE EOS. - 03 success-field LINE 12, PIC X, REQUIRED, - USING success-flag. - - PROCEDURE DIVISION. - DISPLAY scr - ACCEPT scr - - IF success AND COB-CRT-STATUS = 0 - GOBACK RETURNING 0 - ELSE - GOBACK RETURNING 1 - END-IF - . -]) - -AT_CHECK([$COMPILE prog.cob], [0], [], []) -MANUAL_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) - -AT_CLEANUP - - -AT_SETUP([FULL and REQUIRED]) -AT_KEYWORDS([screen]) - -AT_SKIP_IF([test "$COB_HAS_CURSES" != "yes"]) - -AT_DATA([prog.cob], [ - IDENTIFICATION DIVISION. - PROGRAM-ID. prog. - DATA DIVISION. - WORKING-STORAGE SECTION. - 01 dummy PIC X(10). - 01 success-flag PIC X. - 88 success VALUE 'Y', 'y'. - - SCREEN SECTION. - 01 scr. - 03 PIC X(80) - VALUE 'Enter "y" if you cannot continue without filling ' - & 'all of the below field:'. - 03 LINE + 1, PIC X(10), FULL, REQUIRED, TO dummy. - *> no initial value for success as we request input - 03 success-field LINE + 2, PIC X, REQUIRED, TO success-flag. - - PROCEDURE DIVISION. - DISPLAY scr - ACCEPT scr - - IF success AND COB-CRT-STATUS = 0 - GOBACK RETURNING 0 - ELSE - GOBACK RETURNING 1 - END-IF - . -]) - -AT_CHECK([$COMPILE prog.cob], [0], [], []) -MANUAL_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) - -AT_CLEANUP - - -AT_SETUP([HIGHLIGHT]) -AT_KEYWORDS([screen]) - -AT_SKIP_IF([test "$COB_HAS_CURSES" != "yes"]) - -AT_DATA([prog.cob], [ - IDENTIFICATION DIVISION. - PROGRAM-ID. prog. - DATA DIVISION. - WORKING-STORAGE SECTION. - 01 success-flag PIC X VALUE 'Y'. - 88 success VALUE 'Y', 'y'. - - SCREEN SECTION. - 01 scr. - 03 PIC X(80) - VALUE 'Enter "y" if the text below is bright ' - & '(highlighted):'. - 03 LINE + 1, PIC X(10) VALUE 'Highlight' HIGHLIGHT. - 03 success-field LINE + 2, PIC X, REQUIRED, - USING success-flag. - - PROCEDURE DIVISION. - DISPLAY scr - ACCEPT scr - - IF success AND COB-CRT-STATUS = 0 - GOBACK RETURNING 0 - ELSE - GOBACK RETURNING 1 - END-IF - . -]) - -AT_CHECK([$COMPILE prog.cob], [0], [], []) -MANUAL_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) - -AT_CLEANUP - - -AT_SETUP([INITIAL]) -AT_KEYWORDS([screen]) - -AT_SKIP_IF([test "$COB_HAS_CURSES" != "yes"]) - -AT_DATA([prog.cob], [ - IDENTIFICATION DIVISION. - PROGRAM-ID. prog. - - DATA DIVISION. - WORKING-STORAGE SECTION. - 01 dummy-1 PIC X(10). - 01 dummy-2 PIC X(10). - 01 dummy-3 PIC X(10). - - 01 success-flag PIC X VALUE 'Y'. - 88 success VALUE 'Y', 'y'. - - SCREEN SECTION. - 01 scr. - 03 PIC X(80) VALUE 'Enter "y" if the cursor is initially '- - 'located at the start of the rightmost'. - 03 LINE + 1, PIC X(80) VALUE 'field.'. - 03 LINE + 2, PIC X(10) TO dummy-1. - 03 COL + 2, PIC X(10) TO dummy-2. - 03 COL + 2, PIC X(10) TO dummy-3, INITIAL. - 03 success-field LINE + 2, PIC X, REQUIRED, - USING success-flag. - - PROCEDURE DIVISION. - DISPLAY scr - ACCEPT scr - - IF success AND COB-CRT-STATUS = 0 - GOBACK RETURNING 0 - ELSE - GOBACK RETURNING 1 - END-IF - . -]) - -AT_CHECK([$COMPILE prog.cob], [0], [], []) -MANUAL_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) - -AT_CLEANUP - - -AT_SETUP([LEFTLINE]) -AT_KEYWORDS([GRID]) - -AT_SKIP_IF([test "$COB_HAS_CURSES" != "yes"]) - -# Currently not implemented -AT_XFAIL_IF([true]) - -AT_DATA([prog.cob], [ - IDENTIFICATION DIVISION. - PROGRAM-ID. prog. - DATA DIVISION. - WORKING-STORAGE SECTION. - 01 success-flag PIC X VALUE 'Y'. - 88 success VALUE 'Y', 'y'. - - SCREEN SECTION. - 01 scr. - 03 PIC X(80) - VALUE 'Enter "y" if the string has a vertical line to ' - & 'its left:'. - 03 LINE + 1, COL 2, PIC X(10) VALUE 'Leftline' LEFTLINE. - 03 success-field LINE + 2, PIC X, REQUIRED, - USING success-flag. - - PROCEDURE DIVISION. - DISPLAY scr - ACCEPT scr - - IF success AND COB-CRT-STATUS = 0 - GOBACK RETURNING 0 - ELSE - GOBACK RETURNING 1 - END-IF - . -]) - -AT_CHECK([$COMPILE prog.cob], [0], [], []) -MANUAL_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) - -AT_CLEANUP - - -AT_SETUP([LOWLIGHT]) -AT_KEYWORDS([screen]) - -AT_SKIP_IF([test "$COB_HAS_CURSES" != "yes"]) - -AT_DATA([prog.cob], [ - IDENTIFICATION DIVISION. - PROGRAM-ID. prog. - DATA DIVISION. - WORKING-STORAGE SECTION. - 01 success-flag PIC X VALUE 'Y'. - 88 success VALUE 'Y', 'y'. - - SCREEN SECTION. - 01 scr. - 03 PIC X(80) - VALUE 'Enter "y" if the string below is dim (lowlight):'. - 03 LINE + 1, PIC X(10) VALUE 'Lowlight' LOWLIGHT. - 03 success-field LINE + 2, PIC X, REQUIRED, - USING success-flag. - - PROCEDURE DIVISION. - DISPLAY scr - ACCEPT scr - - IF success AND COB-CRT-STATUS = 0 - GOBACK RETURNING 0 - ELSE - GOBACK RETURNING 1 - END-IF - . -]) - -AT_CHECK([$COMPILE prog.cob], [0], [], []) -MANUAL_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) - -AT_CLEANUP - - -AT_SETUP([OVERLINE]) -AT_KEYWORDS([screen]) - -AT_SKIP_IF([test "$COB_HAS_CURSES" != "yes"]) - -# Currently not implemented -AT_XFAIL_IF([true]) - -AT_DATA([prog.cob], [ - IDENTIFICATION DIVISION. - PROGRAM-ID. prog. - DATA DIVISION. - WORKING-STORAGE SECTION. - 01 success-flag PIC X VALUE 'Y'. - 88 success VALUE 'Y', 'y'. - - SCREEN SECTION. - 01 scr. - 03 PIC X(80) - VALUE 'Enter "y" if the string below is overlined:'. - 03 LINE + 1, PIC X(10) VALUE 'Overline' OVERLINE. - 03 success-field LINE + 2, PIC X, REQUIRED, - USING success-flag. - - PROCEDURE DIVISION. - DISPLAY scr - ACCEPT scr - - IF success AND COB-CRT-STATUS = 0 - GOBACK RETURNING 0 - ELSE - GOBACK RETURNING 1 - END-IF - . -]) - -AT_CHECK([$COMPILE prog.cob], [0], [], []) -MANUAL_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) - -AT_CLEANUP - - -AT_SETUP([REVERSE-VIDEO]) -AT_KEYWORDS([screen]) - -AT_SKIP_IF([test "$COB_HAS_CURSES" != "yes"]) - -AT_DATA([prog.cob], [ - IDENTIFICATION DIVISION. - PROGRAM-ID. prog. - DATA DIVISION. - WORKING-STORAGE SECTION. - 01 success-flag PIC X VALUE 'Y'. - 88 success VALUE 'Y', 'y'. - - SCREEN SECTION. - 01 scr. - 03 PIC X(80) - VALUE 'Enter "y" if the background and foreground ' - & 'colours of the string below have'. - 03 LINE + 1, PIC X(80) VALUE 'swapped:'. - 03 LINE + 1, PIC X(20) VALUE 'Reversed colours' - REVERSE-VIDEO. - 03 success-field LINE + 2, PIC X USING success-flag. - - PROCEDURE DIVISION. - DISPLAY scr - ACCEPT scr - - IF success AND COB-CRT-STATUS = 0 - GOBACK RETURNING 0 - ELSE - GOBACK RETURNING 1 - END-IF - . -]) - -AT_CHECK([$COMPILE prog.cob], [0], [], []) -MANUAL_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) - -AT_CLEANUP - - -AT_SETUP([SECURE]) -AT_KEYWORDS([PASSWORD]) - -AT_SKIP_IF([test "$COB_HAS_CURSES" != "yes"]) - -AT_DATA([prog.cob], [ - IDENTIFICATION DIVISION. - PROGRAM-ID. prog. - DATA DIVISION. - WORKING-STORAGE SECTION. - 01 dummy PIC X(10). - 01 success-flag PIC X VALUE 'Y'. - 88 success VALUE 'Y', 'y'. - - SCREEN SECTION. - 01 scr. - 03 PIC X(80) - VALUE 'Enter "y" if text in the field below is replaced ' - & 'with asterisks:'. - 03 LINE + 1, PIC X(10) SECURE TO dummy, PROMPT CHARACTER - "-". - 03 success-field LINE + 2, PIC X, REQUIRED, - USING success-flag. - - PROCEDURE DIVISION. - DISPLAY scr - ACCEPT scr - - IF success AND COB-CRT-STATUS = 0 - GOBACK RETURNING 0 - ELSE - GOBACK RETURNING 1 - END-IF - . -]) - -AT_CHECK([$COMPILE prog.cob], [0], [], []) -MANUAL_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) - -AT_CLEANUP - - -AT_SETUP([SIZE with items]) -AT_KEYWORDS([PROTECTED extensions]) - -AT_SKIP_IF([test "$COB_HAS_CURSES" != "yes"]) - -AT_DATA([prog.cob], [ - IDENTIFICATION DIVISION. - PROGRAM-ID. prog. - DATA DIVISION. - WORKING-STORAGE SECTION. - 01 success-flag PIC X VALUE 'Y'. - 88 success VALUE 'Y', 'y'. - - 01 num-1 PIC 9(5) VALUE 12345. - 01 num-2 PIC X(10) VALUE '12345'. - 01 num-3 PIC 9(4) VALUE 1234. - - 01 four PIC 9 VALUE 4. - - PROCEDURE DIVISION. - DISPLAY 'Enter "y" if you see exactly four rows of 1234, all' - & ' aligned.' LINE 1 - - DISPLAY num-1 LINE 3 COL 3, SIZE 4; - num-2 LINE 4 COL 3, SIZE four; - num-3 LINE 5 COL 3, SIZE 8; - '1234' LINE 6 COL 3, SIZE ZERO - - ACCEPT success-flag LINE 8, REQUIRED UPDATE - - IF success AND COB-CRT-STATUS = 0 - GOBACK RETURNING 0 - ELSE - GOBACK RETURNING 1 - END-IF - . -]) - -AT_CHECK([$COMPILE prog.cob], [0], [], []) -MANUAL_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) - -AT_CLEANUP - - -AT_SETUP([SIZE with figurative constants]) -AT_KEYWORDS([PROTECTED extensions]) - -AT_SKIP_IF([test "$COB_HAS_CURSES" != "yes"]) - -AT_DATA([prog.cob], [ - IDENTIFICATION DIVISION. - PROGRAM-ID. prog. - DATA DIVISION. - WORKING-STORAGE SECTION. - 01 success-flag PIC X VALUE 'Y'. - 88 success VALUE 'Y', 'y'. - - PROCEDURE DIVISION. - DISPLAY 'Enter "y" if you see exactly three rows of quotes, ' - & 'zeroes and ''abc'',', LINE 1 - DISPLAY '8 characters long, all aligned.', LINE 2 - - DISPLAY QUOTES LINE 4 COL 3, SIZE 8; - ZEROES LINE 5 COL 3, SIZE 8; - ALL 'abc' LINE 6 COL 3, SIZE 8 - - DISPLAY '123456789' LINE 7 COL 3 - DISPLAY SPACE LINE 7 COL 3, SIZE 9 - - ACCEPT success-flag LINE 8, REQUIRED UPDATE - - IF success AND COB-CRT-STATUS = 0 - GOBACK RETURNING 0 - ELSE - GOBACK RETURNING 1 - END-IF - . -]) - -AT_CHECK([$COMPILE prog.cob], [0], [], []) -MANUAL_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) - -AT_CLEANUP - - -AT_SETUP([UPDATE]) -AT_KEYWORDS([extensions]) - -AT_SKIP_IF([test "$COB_HAS_CURSES" != "yes"]) - -AT_DATA([prog.cob], [ - IDENTIFICATION DIVISION. - PROGRAM-ID. prog. - DATA DIVISION. - WORKING-STORAGE SECTION. - 01 n-str PIC X(12) VALUE SPACES. - 01 success-flag PIC X. - 88 success VALUE 'Y', 'y'. - - SCREEN SECTION. - 01 scr. - 03 VALUE 'Enter "y" if the entry field below is filled with' - & ' N''s'. - 03 n-field, LINE + 1, PIC X(12) USING n-str. - 03 success-field, LINE + 2, PIC X, REQUIRED, - TO success-flag, FROM 'Y'. - - PROCEDURE DIVISION. - DISPLAY scr - MOVE ALL 'N' TO n-str - ACCEPT scr - - IF success AND COB-CRT-STATUS = 0 - GOBACK RETURNING 0 - ELSE - GOBACK RETURNING 1 - END-IF - . -]) - -AT_CHECK([$COMPILE -fno-accept-update prog.cob], [0], [], []) -MANUAL_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) - -AT_CLEANUP - - -AT_SETUP([UNDERLINE]) -AT_KEYWORDS([screen]) - -AT_SKIP_IF([test "$COB_HAS_CURSES" != "yes"]) - -AT_DATA([prog.cob], [ - IDENTIFICATION DIVISION. - PROGRAM-ID. prog. - DATA DIVISION. - WORKING-STORAGE SECTION. - 01 success-flag PIC X VALUE 'Y'. - 88 success VALUE 'Y', 'y'. - - SCREEN SECTION. - 01 scr. - 03 PIC X(80) - VALUE 'Enter "y" if the string below is underlined:'. - 03 LINE + 1, PIC X(10) VALUE 'Underline' UNDERLINE. - 03 success-field LINE + 2, PIC X, REQUIRED, - USING success-flag. - - PROCEDURE DIVISION. - DISPLAY scr - ACCEPT scr - - IF success AND COB-CRT-STATUS = 0 - GOBACK RETURNING 0 - ELSE - GOBACK RETURNING 1 - END-IF - . -]) - -AT_CHECK([$COMPILE prog.cob], [0], [], []) -MANUAL_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) - -AT_CLEANUP - - -AT_SETUP([SPECIAL-NAMES CURSOR phrase 6-digit with field]) -AT_KEYWORDS([position ACCEPT]) - -AT_SKIP_IF([test "$COB_HAS_CURSES" != "yes"]) - -AT_DATA([prog.cob], [ - IDENTIFICATION DIVISION. - PROGRAM-ID. prog. - ENVIRONMENT DIVISION. - CONFIGURATION SECTION. - SPECIAL-NAMES. - CURSOR IS cur-pos. - DATA DIVISION. - WORKING-STORAGE SECTION. - 77 cur-pos pic 9(06). - 01 success-flag PIC X VALUE 'Y'. - 88 success VALUE 'Y', 'y'. - 01 ws-x-20 PIC X(20). - PROCEDURE DIVISION. - testme. - set environment 'COB_SCREEN_EXCEPTIONS' to 'TRUE' - set environment 'COB_SCREEN_ESC' to 'TRUE' - - DISPLAY "If the cursor below is positioned at the 'C'" - LINE 1 COLUMN 1. - DISPLAY "(third column) below, then position it at the" - LINE 2 COLUMN 1. - DISPLAY "'E' (fifth column) and press ENTER." - LINE 3 COLUMN 1. - - MOVE "ABCDEFG " TO WS-X-20. - MOVE 005003 TO cur-pos. - ACCEPT WS-X-20 - LINE 5 COLUMN 1 - WITH - AUTO-SKIP - SIZE 10 - UPDATE. - - IF cur-pos = 005005 AND COB-CRT-STATUS = 0 - GOBACK RETURNING 0 - ELSE - GOBACK RETURNING 1 - END-IF - . -]) - -AT_CHECK([$COMPILE prog.cob], [0], [], []) -MANUAL_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) - -AT_CLEANUP - - -AT_SETUP([SPECIAL-NAMES CURSOR phrase 4-digit with field]) -AT_KEYWORDS([position ACCEPT]) - -AT_SKIP_IF([test "$COB_HAS_CURSES" != "yes"]) - -AT_DATA([prog.cob], [ - IDENTIFICATION DIVISION. - PROGRAM-ID. prog. - ENVIRONMENT DIVISION. - CONFIGURATION SECTION. - SPECIAL-NAMES. - CURSOR IS cur-pos. - DATA DIVISION. - WORKING-STORAGE SECTION. - 77 cur-pos pic 9(04). - 01 success-flag PIC X VALUE 'Y'. - 88 success VALUE 'Y', 'y'. - 01 ws-x-20 PIC X(20). - PROCEDURE DIVISION. - testme. - set environment 'COB_SCREEN_EXCEPTIONS' to 'TRUE' - set environment 'COB_SCREEN_ESC' to 'TRUE' - - DISPLAY "If the cursor below is positioned at the 'C'" - LINE 1 COLUMN 1. - DISPLAY "(third column) below, then position it at the" - LINE 2 COLUMN 1. - DISPLAY "'E' (fifth column) and press ENTER." - LINE 3 COLUMN 1. - - MOVE "ABCDEFG " TO WS-X-20. - MOVE 0503 TO cur-pos. - ACCEPT WS-X-20 - LINE 5 COLUMN 1 - WITH - AUTO-SKIP - SIZE 10 - UPDATE. - - IF cur-pos = 0505 AND COB-CRT-STATUS = 0 - GOBACK RETURNING 0 - ELSE - GOBACK RETURNING 1 - END-IF - . -]) - -AT_CHECK([$COMPILE prog.cob], [0], [], []) -MANUAL_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) - -AT_CLEANUP - - -AT_SETUP([ACCEPT field WITH CURSOR data-item]) -AT_KEYWORDS([position]) - -AT_SKIP_IF([test "$COB_HAS_CURSES" != "yes"]) - -AT_DATA([prog.cob], [ - IDENTIFICATION DIVISION. - PROGRAM-ID. prog. - DATA DIVISION. - WORKING-STORAGE SECTION. - 77 cur-pos pic 9(04). - 01 success-flag PIC X VALUE 'Y'. - 88 success VALUE 'Y', 'y'. - 01 ws-x-20 PIC X(20). - PROCEDURE DIVISION. - testme. - set environment 'COB_SCREEN_EXCEPTIONS' to 'TRUE' - set environment 'COB_SCREEN_ESC' to 'TRUE' - - DISPLAY "If the cursor below is positioned at the 'C'" - LINE 1 COLUMN 1. - DISPLAY "(third column in field) below, then position it at" - LINE 2 COLUMN 1. - DISPLAY "the 'E' (fifth column) and press ENTER." - LINE 3 COLUMN 1. - - MOVE "ABCDEFG " TO WS-X-20. - MOVE 0003 TO cur-pos. - ACCEPT WS-X-20 - LINE 5 COLUMN 3 - WITH - AUTO-SKIP - SIZE 10 - CURSOR cur-pos - UPDATE. - - IF cur-pos = 0005 AND COB-CRT-STATUS = 0 - GOBACK RETURNING 0 - ELSE - GOBACK RETURNING 1 - END-IF - . -]) - -AT_CHECK([$COMPILE prog.cob], [0], [], []) -MANUAL_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) - -AT_CLEANUP - - -AT_SETUP([ACCEPT field WITH CURSOR size overflow]) -AT_KEYWORDS([position]) - -AT_SKIP_IF([test "$COB_HAS_CURSES" != "yes"]) - -AT_DATA([prog.cob], [ - IDENTIFICATION DIVISION. - PROGRAM-ID. prog. - DATA DIVISION. - WORKING-STORAGE SECTION. - 77 cur-pos pic 9(04). - 01 success-flag PIC X VALUE 'Y'. - 88 success VALUE 'Y', 'y'. - 01 ws-x-20 PIC X(10). - PROCEDURE DIVISION. - testme. - set environment 'COB_SCREEN_EXCEPTIONS' to 'TRUE' - set environment 'COB_SCREEN_ESC' to 'TRUE' - - DISPLAY "If the cursor below is positioned at the last" - LINE 1 COLUMN 1. - DISPLAY "column in the field below, then position it at" - LINE 2 COLUMN 1. - DISPLAY "the 'C' (third column) and press ENTER." - LINE 3 COLUMN 1. - - MOVE "ABCDEFGHIJ" TO WS-X-20. - MOVE 0012 TO cur-pos. - ACCEPT WS-X-20 - LINE 5 COLUMN 3 - WITH - AUTO-SKIP - SIZE 10 - CURSOR cur-pos - UPDATE. - - IF cur-pos = 0003 AND COB-CRT-STATUS = 0 - GOBACK RETURNING 0 - ELSE - GOBACK RETURNING 1 - END-IF - . -]) - -AT_CHECK([$COMPILE prog.cob], [0], [], []) -MANUAL_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) - -AT_CLEANUP - - -AT_SETUP([ACCEPT field WITH CURSOR data overflow I]) -AT_KEYWORDS([position]) - -AT_SKIP_IF([test "$COB_HAS_CURSES" != "yes"]) - -AT_DATA([prog.cob], [ - IDENTIFICATION DIVISION. - PROGRAM-ID. prog. - DATA DIVISION. - WORKING-STORAGE SECTION. - 77 cur-pos pic 9(04). - 01 success-flag PIC X VALUE 'Y'. - 88 success VALUE 'Y', 'y'. - 01 ws-x-20 PIC X(20). - PROCEDURE DIVISION. - testme. - set environment 'COB_SCREEN_EXCEPTIONS' to 'TRUE' - set environment 'COB_SCREEN_ESC' to 'TRUE' - - DISPLAY "If the cursor below is positioned at the 'E'" - LINE 1 COLUMN 1. - DISPLAY "(fifth column in field) below, then position it at" - LINE 2 COLUMN 1. - DISPLAY "the 'C' (third column) and press ENTER." - LINE 3 COLUMN 1. - - MOVE "ABCDE " TO WS-X-20. - MOVE 0008 TO cur-pos. - ACCEPT WS-X-20 - LINE 5 COLUMN 3 - WITH - AUTO-SKIP - SIZE 10 - CURSOR cur-pos - UPDATE. - - IF cur-pos = 0003 AND COB-CRT-STATUS = 0 - GOBACK RETURNING 0 - ELSE - GOBACK RETURNING 1 - END-IF - . -]) - -AT_CHECK([$COMPILE prog.cob], [0], [], []) -MANUAL_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) - -AT_CLEANUP - - -AT_SETUP([ACCEPT field WITH CURSOR data overflow II]) -AT_KEYWORDS([position UNDERLINE]) - -AT_SKIP_IF([test "$COB_HAS_CURSES" != "yes"]) - -AT_DATA([prog.cob], [ - IDENTIFICATION DIVISION. - PROGRAM-ID. prog. - DATA DIVISION. - WORKING-STORAGE SECTION. - 77 cur-pos pic 9(04). - 01 success-flag PIC X VALUE 'Y'. - 88 success VALUE 'Y', 'y'. - 01 ws-x-20 PIC X(20). - PROCEDURE DIVISION. - testme. - set environment 'COB_SCREEN_EXCEPTIONS' to 'TRUE' - set environment 'COB_SCREEN_ESC' to 'TRUE' - - DISPLAY "If the cursor below is positioned at the first" - LINE 1 COLUMN 1. - DISPLAY "column in the field below and it is empty, then" - LINE 2 COLUMN 1. - DISPLAY "enter 'AB', position after the 'B' and press ENTER." - LINE 3 COLUMN 1. - - MOVE "ABCDE " TO WS-X-20. - MOVE 0008 TO cur-pos. - ACCEPT WS-X-20 - LINE 5 COLUMN 3 - WITH - SIZE 10 - UNDERLINE - CURSOR cur-pos. - - IF cur-pos = 0003 AND COB-CRT-STATUS = 0 - GOBACK RETURNING 0 - ELSE - GOBACK RETURNING 1 - END-IF - . -]) - -AT_CHECK([$COMPILE prog.cob], [0], [], []) -MANUAL_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) - -AT_CLEANUP - - -AT_SETUP([ACCEPT field WITH CURSOR literal]) -AT_KEYWORDS([position]) - -AT_SKIP_IF([test "$COB_HAS_CURSES" != "yes"]) - -AT_DATA([prog.cob], [ - IDENTIFICATION DIVISION. - PROGRAM-ID. prog. - DATA DIVISION. - WORKING-STORAGE SECTION. - 01 success-flag PIC X VALUE 'Y'. - 88 success VALUE 'Y', 'y'. - 01 ws-x-20 PIC X(20). - PROCEDURE DIVISION. - testme. - set environment 'COB_SCREEN_EXCEPTIONS' to 'TRUE' - set environment 'COB_SCREEN_ESC' to 'TRUE' - - DISPLAY "If the cursor below is positioned at the 'C'" - LINE 1 COLUMN 1. - DISPLAY "(third column in field) below, then press ENTER." - LINE 2 COLUMN 1. - - MOVE "ABCDEFG " TO WS-X-20. - ACCEPT WS-X-20 - LINE 4 COLUMN 2 - WITH - AUTO-SKIP - SIZE 10 - CURSOR 3 - UPDATE. - - IF COB-CRT-STATUS = 0 - GOBACK RETURNING 0 - ELSE - GOBACK RETURNING 1 - END-IF - . -]) - -AT_CHECK([$COMPILE prog.cob], [0], [], []) -MANUAL_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) - -AT_CLEANUP - - -AT_SETUP([HOME key]) -AT_KEYWORDS([HOME SIZE]) - -AT_SKIP_IF([test "$COB_HAS_CURSES" != "yes"]) - -AT_DATA([prog.cob], [ - IDENTIFICATION DIVISION. - PROGRAM-ID. prog. - DATA DIVISION. - WORKING-STORAGE SECTION. - 01 success-flag PIC X VALUE 'Y'. - 88 success VALUE 'Y', 'y'. - 01 ws-x-20 PIC X(20). - PROCEDURE DIVISION. - DISPLAY "Enter 'y' if multiple presses of the HOME key" - LINE 1 COLUMN 1. - DISPLAY "go to the beginning of the field and the beginning" - LINE 2 COLUMN 1. - DISPLAY "of the characters." - LINE 3 COLUMN 1. - - MOVE " ABC " TO WS-X-20. - ACCEPT WS-X-20 - LINE 5 COLUMN 1 - WITH - AUTO-SKIP - SIZE 10 - UPDATE. - - ACCEPT SUCCESS-FLAG - LINE 7 COLUMN 1 - WITH UPDATE. - - IF success AND COB-CRT-STATUS = 0 - GOBACK RETURNING 0 - ELSE - GOBACK RETURNING 1 - END-IF - . -]) - -AT_CHECK([$COMPILE prog.cob], [0], [], []) -MANUAL_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) - -AT_CLEANUP - - -AT_SETUP([END key]) -AT_KEYWORDS([END SIZE position]) - -AT_SKIP_IF([test "$COB_HAS_CURSES" != "yes"]) - -AT_DATA([prog.cob], [ - IDENTIFICATION DIVISION. - PROGRAM-ID. prog. - DATA DIVISION. - WORKING-STORAGE SECTION. - 01 success-flag PIC X VALUE 'Y'. - 88 success VALUE 'Y', 'y'. - 01 ws-x-20 PIC X(20). - PROCEDURE DIVISION. - DISPLAY "Enter 'y' if multiple presses of the END key" - LINE 1 COLUMN 1. - DISPLAY "go to the end of the field and just after the end" - LINE 2 COLUMN 1. - DISPLAY "of the characters." - LINE 3 COLUMN 1. - - MOVE " ABC " TO WS-X-20. - ACCEPT WS-X-20 - LINE 5 COLUMN 1 - WITH - AUTO-SKIP - SIZE 10 - UPDATE. - - ACCEPT SUCCESS-FLAG - LINE 7 COLUMN 1 - WITH UPDATE. - - IF success AND COB-CRT-STATUS = 0 - GOBACK RETURNING 0 - ELSE - GOBACK RETURNING 1 - END-IF - . -]) - -AT_CHECK([$COMPILE prog.cob], [0], [], []) -MANUAL_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) - -AT_CLEANUP - - -AT_SETUP([INSERT key]) -AT_KEYWORDS([COB_INSERT_MODE SIZE]) - -AT_SKIP_IF([test "$COB_HAS_CURSES" != "yes"]) - -AT_DATA([prog.cob], [ - IDENTIFICATION DIVISION. - PROGRAM-ID. prog. - DATA DIVISION. - WORKING-STORAGE SECTION. - 01 success-flag PIC X VALUE 'Y'. - 88 success VALUE 'Y', 'y'. - 01 ws-x-20 PIC X(20). - PROCEDURE DIVISION. - DISPLAY "Enter 'y' if multiple presses of the INSERT key" - LINE 1 COLUMN 1. - DISPLAY "go back and forth between" - LINE 2 COLUMN 1. - DISPLAY "Insert Mode ON (characters move to the right)" - LINE 3 COLUMN 1. - DISPLAY "and Insert Mode OFF (characters type over)." - LINE 4 COLUMN 1. - - MOVE "ABCD " TO WS-X-20. - ACCEPT WS-X-20 - LINE 6 COLUMN 1 - WITH - AUTO-SKIP - SIZE 10 - UPDATE. - - ACCEPT SUCCESS-FLAG - LINE 8 COLUMN 1 - WITH UPDATE. - - IF success AND COB-CRT-STATUS = 0 - GOBACK RETURNING 0 - ELSE - GOBACK RETURNING 1 - END-IF - . -]) - -AT_CHECK([$COMPILE prog.cob], [0], [], []) -MANUAL_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) - -AT_CLEANUP - - -AT_SETUP([cursor visibility]) -AT_KEYWORDS([COB_HIDE_CURSOR]) - -AT_SKIP_IF([test "$COB_HAS_CURSES" != "yes"]) - -AT_DATA([prog.cob], [ - IDENTIFICATION DIVISION. - PROGRAM-ID. prog. - DATA DIVISION. - WORKING-STORAGE SECTION. - 01 success-flag PIC X VALUE 'Y'. - 88 fail VALUE 'N'. - 01 ws-input PIC X. - 88 success VALUE 'Y', 'y'. - PROCEDURE DIVISION. - DISPLAY "Type 'Y' if you see the cursor" - LINE 1 COLUMN 1. - - ACCEPT WS-INPUT - LINE 1 COLUMN 50 - WITH AUTO-SKIP - UPDATE. - IF NOT success SET fail TO TRUE. - - SET ENVIRONMENT 'COB_HIDE_CURSOR' TO 'TRUE'. - - DISPLAY "Type 'Y' if you do not see the cursor" - LINE 3 COLUMN 1. - - ACCEPT WS-INPUT - LINE 3 COLUMN 50 - WITH AUTO-SKIP - UPDATE. - IF NOT success SET fail TO TRUE. - - SET ENVIRONMENT 'COB_INSERT_MODE' TO 'TRUE'. - - DISPLAY "Type 'Y' if you still do not see the cursor" - LINE 5 COLUMN 1. - - ACCEPT WS-INPUT - LINE 5 COLUMN 50 - WITH AUTO-SKIP - UPDATE. - IF NOT success SET fail TO TRUE. - - IF fail - GOBACK RETURNING 1 - ELSE - GOBACK RETURNING 0 - END-IF - . -]) - -AT_CHECK([$COMPILE prog.cob], [0], [], []) -MANUAL_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) - -AT_CLEANUP - - -AT_SETUP([BACKSPACE key]) -AT_KEYWORDS([SIZE CURSOR position]) - -AT_SKIP_IF([test "$COB_HAS_CURSES" != "yes"]) - -AT_DATA([prog.cob], [ - IDENTIFICATION DIVISION. - PROGRAM-ID. prog. - ENVIRONMENT DIVISION. - CONFIGURATION SECTION. - SPECIAL-NAMES. - CURSOR IS cur-pos. - DATA DIVISION. - WORKING-STORAGE SECTION. - 77 cur-pos pic 9(06). - 01 success-flag PIC X VALUE 'Y'. - 88 success VALUE 'Y', 'y'. - 01 ws-x-20 PIC X(20). - PROCEDURE DIVISION. - DISPLAY "Enter 'y' if each press of the BACKSPACE key" - LINE 1 COLUMN 1. - DISPLAY "deletes the character to the left and moves the" - LINE 2 COLUMN 1. - DISPLAY "cursor and remaining characters one space to the" - LINE 3 COLUMN 1. - DISPLAY "left." - LINE 4 COLUMN 1. - - MOVE "ABCD " TO WS-X-20. - MOVE 006002 TO cur-pos. - ACCEPT WS-X-20 - LINE 6 COLUMN 1 - WITH - AUTO-SKIP - SIZE 10 - UPDATE. - - ACCEPT SUCCESS-FLAG - LINE 8 COLUMN 1 - WITH UPDATE. - - IF success AND COB-CRT-STATUS = 0 - GOBACK RETURNING 0 - ELSE - GOBACK RETURNING 1 - END-IF - . -]) - -AT_CHECK([$COMPILE prog.cob], [0], [], []) -MANUAL_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) - -AT_CLEANUP - - -AT_SETUP([DELETE key]) -AT_KEYWORDS([SIZE position]) - -AT_SKIP_IF([test "$COB_HAS_CURSES" != "yes"]) - -AT_DATA([prog.cob], [ - IDENTIFICATION DIVISION. - PROGRAM-ID. prog. - DATA DIVISION. - WORKING-STORAGE SECTION. - 01 success-flag PIC X VALUE 'Y'. - 88 success VALUE 'Y', 'y'. - 01 ws-x-20 PIC X(20). - PROCEDURE DIVISION. - DISPLAY "Enter 'y' if each press of the DELETE key deletes" - LINE 1 COLUMN 1. - DISPLAY "the cursor character and moves the remaining" - LINE 2 COLUMN 1. - DISPLAY "characters one space to the left. And the cursor" - LINE 3 COLUMN 1. - DISPLAY "does not move." - LINE 4 COLUMN 1. - - MOVE "ABCD " TO WS-X-20. - ACCEPT WS-X-20 - LINE 6 COLUMN 1 - WITH - AUTO-SKIP - SIZE 10 - UPDATE. - - ACCEPT SUCCESS-FLAG - LINE 8 COLUMN 1 - WITH UPDATE. - - IF success AND COB-CRT-STATUS = 0 - GOBACK RETURNING 0 - ELSE - GOBACK RETURNING 1 - END-IF - . -]) - -AT_CHECK([$COMPILE prog.cob], [0], [], []) -MANUAL_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) - -AT_CLEANUP - - -AT_SETUP([ALT DELETE key]) -AT_KEYWORDS([ALT-DELETE SIZE]) - -AT_SKIP_IF([test "$COB_HAS_CURSES" != "yes"]) - -AT_DATA([prog.cob], [ - IDENTIFICATION DIVISION. - PROGRAM-ID. prog. - DATA DIVISION. - WORKING-STORAGE SECTION. - 01 success-flag PIC X VALUE 'Y'. - 88 success VALUE 'Y', 'y'. - 01 ws-x-20 PIC X(20). - PROCEDURE DIVISION. - DISPLAY "Enter 'y' if pressing the ALT and DELETE keys" - LINE 1 COLUMN 1. - DISPLAY "deletes all characters from the cursor to the end" - LINE 2 COLUMN 1. - DISPLAY "of the field. And the cursor does not move." - LINE 3 COLUMN 1. - - MOVE "ABCD " TO WS-X-20. - ACCEPT WS-X-20 - LINE 5 COLUMN 1 - WITH - AUTO-SKIP - SIZE 10 - UPDATE. - - ACCEPT SUCCESS-FLAG - LINE 7 COLUMN 1 - WITH UPDATE. - - IF success AND COB-CRT-STATUS = 0 - GOBACK RETURNING 0 - ELSE - GOBACK RETURNING 1 - END-IF - . -]) - -AT_CHECK([$COMPILE prog.cob], [0], [], []) -MANUAL_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) - -AT_CLEANUP - - -AT_SETUP([ALT LEFT-ARROW key]) -AT_KEYWORDS([ALT-LEFT-ARROW SIZE]) - -AT_SKIP_IF([test "$COB_HAS_CURSES" != "yes"]) - -AT_DATA([prog.cob], [ - IDENTIFICATION DIVISION. - PROGRAM-ID. prog. - DATA DIVISION. - WORKING-STORAGE SECTION. - 01 success-flag PIC X VALUE 'Y'. - 88 success VALUE 'Y', 'y'. - 01 ws-x-20 PIC X(20). - PROCEDURE DIVISION. - DISPLAY "Enter 'y' if pressing the ALT and LEFT-ARROW keys" - LINE 1 COLUMN 1. - DISPLAY "at the first column does not exit the field." - LINE 2 COLUMN 1. - DISPLAY "But the LEFT-ARROW without ALT does exit." - LINE 3 COLUMN 1. - - MOVE "ABCD " TO WS-X-20. - ACCEPT WS-X-20 - LINE 5 COLUMN 1 - WITH - AUTO-SKIP - SIZE 10 - UPDATE. - - ACCEPT SUCCESS-FLAG - LINE 7 COLUMN 1 - WITH UPDATE. - - IF success AND COB-CRT-STATUS = 0 - GOBACK RETURNING 0 - ELSE - GOBACK RETURNING 1 - END-IF - . -]) - -AT_CHECK([$COMPILE prog.cob], [0], [], []) -MANUAL_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) - -AT_CLEANUP - - -AT_SETUP([ALT RIGHT-ARROW key]) -AT_KEYWORDS([SIZE]) - -AT_SKIP_IF([test "$COB_HAS_CURSES" != "yes"]) - -AT_DATA([prog.cob], [ - IDENTIFICATION DIVISION. - PROGRAM-ID. prog. - DATA DIVISION. - WORKING-STORAGE SECTION. - 01 success-flag PIC X VALUE 'Y'. - 88 success VALUE 'Y', 'y'. - 01 ws-x-10 PIC X(10). - PROCEDURE DIVISION. - DISPLAY "Enter 'y' if pressing the ALT and RIGHT-ARROW keys" - LINE 1 COLUMN 1. - DISPLAY "at the last column does not exit the field." - LINE 2 COLUMN 1. - DISPLAY "But the RIGHT-ARROW without ALT does exit." - LINE 3 COLUMN 1. - - MOVE "ABCDE" TO WS-X-10. - ACCEPT WS-X-10 - LINE 5 COLUMN 1 - WITH - AUTO-SKIP - SIZE 5 - UPDATE. - - ACCEPT SUCCESS-FLAG - LINE 7 COLUMN 1 - WITH UPDATE. - - IF success AND COB-CRT-STATUS = 0 - GOBACK RETURNING 0 - ELSE - GOBACK RETURNING 1 - END-IF - . -]) - -AT_CHECK([$COMPILE prog.cob], [0], [], []) -MANUAL_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) - -AT_CLEANUP - - -AT_SETUP([CURSOR clause]) -AT_KEYWORDS([SPECIAL-NAMES]) - -AT_SKIP_IF([test "$COB_HAS_CURSES" != "yes"]) - -AT_DATA([prog1.cob], [ - identification division. - program-id. prog. - - environment division. - configuration section. - special-names. - cursor is my-cur. - data division. - working-storage section. - - 01 my-cur. - 05 my-row pic 9(3) value 0. - 05 my-col pic 9(3) value 0. - - 77 loop pic 99. - 77 cursor-moves-here pic x(20). - - screen section. - - 01 screen-example . - 05 message1 value is "row (view only) is " line 1 col 10. - 05 filler pic 9(3) from my-row. - - 05 message2 value is "col (adjust only) is " line 2 col 10. - 05 filler pic 9(3) using my-col. - - 05 filler pic x(20) using cursor-moves-here line 3 col 14. - - procedure division. - - perform varying loop from 1 by 1 - until loop > 10 - display "screen accept no. " - at line 10 col 4 - loop "/10" - display screen-example - accept screen-example - end-perform - - goback. -]) - -# note: same test, but this time with different specified -# special-names reference -AT_DATA([prog2.cob], [ - identification division. - program-id. prog. - - data division. - working-storage section. - - 01 my-cur is special-names cursor. - 05 my-row pic 9(3) value 0. - 05 my-col pic 9(3) value 0. - - 77 loop pic 99. - 77 cursor-moves-here pic x(20). - - screen section. - - 01 screen-example . - 05 message1 value is "row (view only) is " line 1 col 10. - 05 filler pic 9(3) from my-row. - - 05 message2 value is "col (adjust only) is " line 2 col 10. - 05 filler pic 9(3) using my-col. - - 05 filler pic x(20) using cursor-moves-here line 3 col 14. - - procedure division. - - perform varying loop from 1 by 1 - until loop > 10 - display "screen accept no. " - at line 10 col 4 - loop "/10" - display screen-example - accept screen-example - end-perform - - goback. -]) - -AT_CHECK([$COMPILE prog1.cob], [0], [], []) -AT_CHECK([$COMPILE prog2.cob], [0], [], []) - -# user-instructions what to test is missing -AT_SKIP_IF([true]) - -MANUAL_CHECK([$COBCRUN_DIRECT ./prog1], [0], [], []) -MANUAL_CHECK([$COBCRUN_DIRECT ./prog2], [0], [], []) - -AT_CLEANUP - - -AT_SETUP([CRT STATUS clause]) -AT_KEYWORDS([SPECIAL-NAMES]) - -AT_SKIP_IF([test "$COB_HAS_CURSES" != "yes"]) - -AT_DATA([prog1.cob], [ - identification division. - program-id. prog. - - environment division. - configuration section. - special-names. - crt status is my-status. - data division. - working-storage section. - - 01 my-status. - 05 one pic X. - 05 two pic X. - 05 three pic X. - 05 four pic X. - - 77 loop pic 99. - 77 test-field pic x(5). - - screen section. - - 01 screen-example . - 05 message1 value is "status: " line 1 col 10. - 05 filler pic x(4) from my-status. - - 05 message2 value is "test-field: " line 2 col 10. - 05 filler pic x(5) using test-field. - - procedure division. - - set environment 'COB_SCREEN_EXCEPTIONS' to 'TRUE' - set environment 'COB_SCREEN_ESC' to 'TRUE' - perform varying loop from 1 by 1 - until loop > 10 - display "screen accept no. " - at line 10 col 4 - loop "/10" - display screen-example - accept screen-example - end-perform - - goback. -]) - -# note: same test, but this time with different specified -# special-names reference -AT_DATA([prog2.cob], [ - identification division. - program-id. prog. - - data division. - working-storage section. - - 77 my-status pic 9(05) is special-names crt status. - - 77 loop pic 99. - 77 test-field pic x(5). - - screen section. - - 01 screen-example . - 05 message1 value is "status: " line 1 col 10. - 05 filler pic 9(05) from my-status. - - 05 message2 value is "test-field: " line 2 col 10. - 05 filler pic x(5) using test-field. - - procedure division. - - set environment 'COB_SCREEN_EXCEPTIONS' to 'TRUE' - set environment 'COB_SCREEN_ESC' to 'TRUE' - perform varying loop from 1 by 1 - until loop > 10 - display "screen accept no. " - at line 10 col 4 - loop "/10" - display screen-example - accept screen-example - end-perform - - goback. -]) - -AT_CHECK([$COMPILE prog1.cob], [0], [], []) -AT_CHECK([$COMPILE prog2.cob], [0], [], []) - -# user-instructions what to test is missing -AT_SKIP_IF([true]) - -MANUAL_CHECK([$COBCRUN_DIRECT ./prog1], [0], [], []) -MANUAL_CHECK([$COBCRUN_DIRECT ./prog2], [0], [], []) - -AT_CLEANUP - - -AT_SETUP([CRT STATUS clause]) -AT_KEYWORDS([SPECIAL-NAMES]) - -AT_SKIP_IF([test "$COB_HAS_CURSES" != "yes"]) - -AT_DATA([prog.cob], [ - identification division. - program-id. prog-crt4. - - data division. - working-storage section. - - 01 crt4 pic 9(4) is special-names crt status. - - 01 test-tab. - 05 test-01 pic x(20) value "Function key 01 1001". - 05 test-02 pic x(20) value "Function key 02 1002". - 05 test-03 pic x(20) value "Function key 03 1003". - 05 test-04 pic x(20) value "Function key 04 1004". - 05 test-05 pic x(20) value "Function key 05 1005". - 05 test-06 pic x(20) value "Prev-page key 2001". - 05 test-07 pic x(20) value "Next-page key 2002". - - 01 test-rab-r redefines test-tab. - 05 test-data occurs 7 times. - 10 test-name pic x(16). - 10 test-crt4 pic 9(4). - - 01 linenr pic 9(2) value 0. - - 01 test-result-4 pic 9(4). - - 01 return-value pic 9 value 0. - - 77 loop pic 9(2). - 77 test-field pic x. - - - procedure division. - - set environment 'COB_SCREEN_EXCEPTIONS' to 'TRUE' - set environment 'COB_SCREEN_ESC' to 'TRUE' - - perform forever - display spaces with blank screen - - move 0 to return-value - perform varying loop from 1 by 1 until loop > 7 - compute linenr = loop + 5 - - display "Please press " line linenr, column 1 - display test-name(loop) line linenr, column 14 - - move spaces to test-field - accept test-field - line linenr column 30 - - display crt4 line linenr, column 30 - - if crt4 = test-crt4(loop) - display "passed" line linenr, column 36 - else - move 1 to return-value - display "failed" line linenr, column 36 - end-if - end-perform - - if return-value = 0 - exit perform - end-if - - display "Try again? (Y/n) " line 20, column 1 - move "Y" to test-field - accept test-field line 20, column 18 - if not (test-field = "Y" or "y") - exit perform - end-if - end-perform - - goback returning return-value - . -]) - -AT_CHECK([$COMPILE prog.cob], [0], [], []) - -MANUAL_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) - -AT_CLEANUP - - -AT_SETUP([X/Open CRT STATUS clause]) -AT_KEYWORDS([SPECIAL-NAMES]) - -AT_SKIP_IF([test "$COB_HAS_CURSES" != "yes"]) - -AT_DATA([prog.cob], [ - identification division. - program-id. prog-crt3. - - data division. - working-storage section. - - 01 crt3 is special-names crt status. - 05 crt3-1 pic 9. - 05 crt3-2 usage binary-char unsigned. - 05 crt3-3 usage binary-char unsigned. - - 01 test-tab. - 05 test-01 pic x(20) value "Function key 01 1001". - 05 test-02 pic x(20) value "Function key 02 1002". - 05 test-03 pic x(20) value "Function key 03 1003". - 05 test-04 pic x(20) value "Function key 04 1004". - 05 test-05 pic x(20) value "Function key 05 1005". - 05 test-06 pic x(20) value "Prev-page key 2001". - 05 test-07 pic x(20) value "Next-page key 2002". - - 01 test-rab-r redefines test-tab. - 05 test-data occurs 7 times. - 10 test-name pic x(16). - 10 test-crt31 pic 9. - 10 test-crt32 pic 9(3). - - 01 linenr pic 9(2) value 0. - - 01 test-result-1 pic 9. - 01 test-result-3 pic 9(3). - - 01 return-value pic 9 value 0. - - 77 loop pic 9(2). - 77 test-field pic x. - - - procedure division. - - set environment 'COB_SCREEN_EXCEPTIONS' to 'TRUE' - set environment 'COB_SCREEN_ESC' to 'TRUE' - - perform forever - display spaces with blank screen - - move 0 to return-value - perform varying loop from 1 by 1 until loop > 7 - compute linenr = loop + 5 - - display "Please press " line linenr, column 1 - display test-name(loop) line linenr, column 14 - - move spaces to test-field - accept test-field - line linenr column 30 - - move crt3-1 to test-result-1 - display test-result-1 line linenr, column 30 - - move crt3-2 to test-result-3 - display test-result-3 line linenr, column 32 - - if test-result-1 = test-crt31(loop) and - test-result-3 = test-crt32(loop) - display "passed" line linenr, column 36 - else - move 1 to return-value - display "failed" line linenr, column 36 - end-if - end-perform - - if return-value = 0 - exit perform - end-if - - display "Try again? (Y/n) " line 20, column 1 - move "Y" to test-field - accept test-field line 20, column 18 - if not (test-field = "Y" or "y") - exit perform - end-if - end-perform - - goback returning return-value - . -]) - -AT_CHECK([$COMPILE prog.cob], [0], [], []) - -MANUAL_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) - -AT_CLEANUP - -AT_SETUP([simple ACCEPT field WITH UPDATE]) -AT_KEYWORDS([screen]) - -AT_SKIP_IF([test "$COB_HAS_CURSES" != "yes"]) - -AT_DATA([prog.cob], [ - IDENTIFICATION DIVISION. - PROGRAM-ID. prog. - DATA DIVISION. - WORKING-STORAGE SECTION. - 77 var pic x(11) value 'ignore this'. - 01 success-flag PIC X VALUE 'y'. - 88 success VALUE 'Y', 'y'. - - PROCEDURE DIVISION. - display "Press ENTER if you see an ""y"" " - at 0302 - accept success-flag update. - - IF success AND COB-CRT-STATUS = 0 - GOBACK RETURNING 0 - ELSE - GOBACK RETURNING 1 - END-IF - . -]) - -AT_CHECK([$COMPILE prog.cob], [0], [], []) -MANUAL_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) - -AT_CLEANUP - - -AT_SETUP([VALUE ALL in SCREEN SECTION]) - -AT_SKIP_IF([test "$COB_HAS_CURSES" != "yes"]) - -AT_DATA([prog.cob], [ - IDENTIFICATION DIVISION. - PROGRAM-ID. SCREEN-VALUE-ALL. - - DATA DIVISION. - WORKING-STORAGE SECTION. - - SCREEN SECTION. - 01 SCREEN001 BLANK SCREEN AUTO-SKIP. - 03 SCR01 BACKGROUND-COLOR 2 FOREGROUND-COLOR 7. - 05 LINE 02 COL 001 PIC X(50) VALUE ALL '-'. - - PROCEDURE DIVISION. - DISPLAY 'Press ENTER if you see a sequence of ""-""' - AT 0101 END-DISPLAY - DISPLAY ' ' AT 0201 END-DISPLAY - ACCEPT SCREEN001 - ACCEPT OMITTED - GOBACK. -]) - -AT_CHECK([$COMPILE prog.cob], [0], [], []) -MANUAL_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) - -AT_CLEANUP - - -AT_SETUP([CURSOR position in line 1]) -AT_KEYWORDS([screen]) - -AT_SKIP_IF([test "$COB_HAS_CURSES" != "yes"]) - -AT_DATA([prog.cob], [ - IDENTIFICATION DIVISION. - PROGRAM-ID. PROG. - ENVIRONMENT DIVISION. - CONFIGURATION SECTION. - SPECIAL-NAMES. - CURSOR IS CURSOR-POSITION. - - DATA DIVISION. - - WORKING-STORAGE SECTION. - - 01 CURSOR-POSITION. - 05 CSR-ROW-NUMBER PIC 9(03) VALUE 001. - 05 CSR-COL-NUMBER PIC 9(03) VALUE 005. - - 01 WORK-FIELDS. - 05 IN-ID PIC X(09) VALUE SPACES. - 05 TRAN-ID PIC X(03) VALUE 'ABC'. - - 01 SUCCESS-FLAG PIC X VALUE 'Y'. - 88 SUCCESS VALUE 'y', 'Y'. - - SCREEN SECTION. - - 01 EMPLOYEE-SCREEN - BACKGROUND-COLOR IS 0 - FOREGROUND-COLOR IS 7. - - 05 LINE 01 COL 01 AUTO PIC X(03) USING - TRAN-ID. - 05 LINE 01 COL 04 PIC X(01) VALUE - ','. - 05 LINE 01 COL 05 AUTO PIC X(09) USING - IN-ID. - - 05 LINE 5 VALUE 'cursor should be ' - & 'at line 1 and column 5'. - 05 LINE 6 VALUE 'go to line 10 ' - & 'and enter an "y" or "n" '. - 05 LINE 10 PIC X, REQUIRED USING success-flag. - - PROCEDURE DIVISION. - - DISPLAY EMPLOYEE-SCREEN. - ACCEPT EMPLOYEE-SCREEN. - - IF SUCCESS AND COB-CRT-STATUS = 0 - GOBACK RETURNING 0 - ELSE - GOBACK RETURNING 1 - END-IF. - -]) - -AT_CHECK([$COMPILE prog.cob], [0], [], []) -MANUAL_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) - -AT_CLEANUP - - -AT_SETUP([ACCEPT SCREEN TIMEOUT]) -AT_KEYWORDS([crt status cursor]) - -AT_SKIP_IF([test "$COB_HAS_CURSES" != "yes"]) - -AT_DATA([prog.cob], [ - REPLACE ==:BCOL:== BY ==BACKGROUND-COLOR==; ==:FCOL:== BY - ==FOREGROUND-COLOR==. - ** ************************************************************* - ** - ** ************************************************************* - IDENTIFICATION DIVISION. - PROGRAM-ID. PROG. - * GnuCOBOL sample - ENVIRONMENT DIVISION. - CONFIGURATION SECTION. - SPECIAL-NAMES. - CRT STATUS IS WCRT-STATUS. - CURSOR IS WCURSORROWCOL. - DATA DIVISION. - - WORKING-STORAGE SECTION. - 77 K-ENTER PIC 9(04) VALUE 0000. - 77 K-TIMEOUT PIC 9(04) VALUE 8001. - - 01 WCRT-STATUS PIC 9(04) VALUE ZERO. - 01 WCURSORROWCOL PIC 9(06) VALUE 000000. - 01 REDEFINES WCURSORROWCOL . - 05 WCURSORROW PIC 9(03). - 05 WCURSORCOL PIC 9(03). - 01 BLACK CONSTANT AS 00. - 01 BLUE CONSTANT AS 01. - 01 GREEN CONSTANT AS 02. - 01 CYAN CONSTANT AS 03. - 01 RED CONSTANT AS 04. - 01 MAGENTA CONSTANT AS 05. - * old color code as yellow - 01 BROWN CONSTANT AS 06. - * or Light Gray - 01 WHITE CONSTANT AS 07. - * or Dark Gray - 01 GREY CONSTANT AS 08. - * same color code as Grey - 01 LIGHTBLACK CONSTANT AS 08. - 01 LIGHTBLUE CONSTANT AS 09. - 01 LIGHTGREEN CONSTANT AS 10. - 01 LIGHTCYAN CONSTANT AS 11. - 01 LIGHTRED CONSTANT AS 12. - 01 LIGHTMAGENTA CONSTANT AS 13. - 01 PINK CONSTANT AS 13. - 01 YELLOW CONSTANT AS 14. - 01 LIGHTWHITE CONSTANT AS 15. - - - - 01 W-VAR-SELECTION. - 02 W-DATA PIC X(8). - 02 W-REPLY PIC X(01). - 88 SUCCESS VALUE 'Y', 'y'. - - - SCREEN SECTION. - - 01 SCREEN-SELECTION. - 02 LINE 06 COL 05 :FCOL: BLACK :BCOL: CYAN - VALUE 'TIMEOUT TEST - ENTER 4 CHARACTERS OF DATA' & - ' AND PAUSE UNTIL TIME CHANGES'. - 02 LINE 07 COL 05 :FCOL: BLACK :BCOL: CYAN - VALUE ' THEN ENTER 4 MORE CHARACTERS OF DATA' & - ' AND PAUSE UNTIL TIME CHANGES'. - 02 LINE 08 COL 05 :FCOL: BLACK :BCOL: CYAN - VALUE ' THEN AFTER THE TIME CHANGES ' & - ' ENTER A Y IN THE REPY LINE IF THE DATA ' & - ' IS CORRECT'. - - 02 LINE 15 COL 20 VALUE 'Data Entry:'. - 02 LINE + 2 COL 20 VALUE 'Reply:'. - 02 LINE 15 COL 40 PIC A(08) AUTO-SKIP USING W-DATA - HIGHLIGHT. - 02 LINE + 2 COL 40 PIC X AUTO-SKIP USING W-REPLY - HIGHLIGHT. - - PROCEDURE DIVISION. - - MAIN-LOOP. - DISPLAY SCREEN-SELECTION - CALL 'TIMEDISP' - - PERFORM WITH TEST AFTER UNTIL WCRT-STATUS <> K-TIMEOUT - ACCEPT SCREEN-SELECTION WITH TIMEOUT 1 - ON EXCEPTION CALL 'TIMEDISP' - END-ACCEPT - END-PERFORM. - - IF SUCCESS AND WCRT-STATUS = 0 - GOBACK RETURNING 0 - ELSE - GOBACK RETURNING 1 - END-IF - . - - GOBACK. - - ** ************************************************************* - * - ** ************************************************************* - ID DIVISION. - PROGRAM-ID. TIMEDISP. - DATA DIVISION. - WORKING-STORAGE SECTION. - 01 SWITCH PIC X. - 01 BLUE CONSTANT AS 01. - 01 RED CONSTANT AS 04. - 01 CYAN CONSTANT AS 03. - 01 WHITE CONSTANT AS 07. - 01 WDAY PIC 9(08). - 01 WTIME PIC 9(08). - 01 DATE-TIME PIC X(19). - PROCEDURE DIVISION. - ACCEPT WDAY FROM DATE YYYYMMDD - ACCEPT WTIME FROM TIME - STRING WDAY(1:4) '.' WDAY(5:2) '.' WDAY(7:2) ' ' - WTIME(1:2) ':' WTIME(3:2) ':' WTIME(5:2) DELIMITED BY - SIZE INTO DATE-TIME - IF SWITCH EQUAL 'N' - DISPLAY DATE-TIME AT 002061 :BCOL: CYAN :FCOL: WHITE - END-DISPLAY - MOVE 'Y' TO SWITCH - ELSE - DISPLAY DATE-TIME AT 002061 :BCOL: RED :FCOL: WHITE - END-DISPLAY - MOVE 'N' TO SWITCH - END-IF. - CONTINUE. - ENDPROGRAM. - GOBACK. - END PROGRAM TIMEDISP. - - END PROGRAM PROG. -]) - -AT_CHECK([$COMPILE prog.cob], [0], [], []) -MANUAL_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) - -AT_CLEANUP - - -AT_SETUP([system function CBL_GC_WINDOW]) -AT_KEYWORDS([screen]) - -AT_SKIP_IF([test "$COB_HAS_CURSES" != "yes"]) - -AT_DATA([prog.cob], [ -GNU >>SOURCE FORMAT IS FIXED -COBOL *> *************************************************************** - *> DATE: 20200630 - *> LICENSE: PUBLIC DOMAIN -COLORS*> PURPOSE: SHOW THE GNUCOBOL DEFAULT COLOUR PALETTE - *> TECTONICS: COBC -X GNUCOBOL-COLOURS.COB - *> *************************************************************** - IDENTIFICATION DIVISION. - PROGRAM-ID. SAMPLE. - - ENVIRONMENT DIVISION. - CONFIGURATION SECTION. - *SOURCE-COMPUTER. IBM-PC WITH DEBUGGING MODE. - OBJECT-COMPUTER. IBM-PC. - - REPOSITORY. - FUNCTION ALL INTRINSIC. - - DATA DIVISION. - WORKING-STORAGE SECTION. - - * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * - * * - * NEW WINDOW FUNCTIONS. * - * * - * CBL_GC_WINDOW * - * * - * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * - - 01 BLACK CONSTANT AS 0. - 01 BLUE CONSTANT AS 1. - 01 GREEN CONSTANT AS 2. - 01 CYAN CONSTANT AS 3. - 01 RED CONSTANT AS 4. - 01 MAGENTA CONSTANT AS 5. - 01 BROWN CONSTANT AS 6. - 01 WHITE CONSTANT AS 7. - - 77 ANSWER-TEXT PIC X. - - 01 SW-EVEN PIC X VALUE 'N'. - 01 CNTR PIC S9(9) COMP-5 VALUE +0. - 01 CNTR-ROW PIC S9(9) COMP-5 VALUE +0. - 01 CNTR-COL PIC S9(9) COMP-5 VALUE +0. - - 01 CURSOR-LOCN-BUFFER. - 05 CURSOR-LINE USAGE BINARY-CHAR UNSIGNED. - 05 CURSOR-COLUMN USAGE BINARY-CHAR UNSIGNED. - - 01 TMP. - 05 TMP-LINE PIC 9(4) COMP-5. - 05 TMP-COLUMN PIC 9(4) COMP-5. - - COPY 'gcwindow'. - - SCREEN SECTION. - 01 GNUCOBOL-COLOURS. - 05 LINE 1 COLUMN 1 VALUE "GNUCOBOL COLOURS". - 05 LINE 2 COLUMN 1 VALUE "==================". - - 05 LINE 4 COLUMN 1 VALUE "DEFAULT HIGHLIGHT " - & "LOWLIGHT REVERSE-VIDEO ". - 05 LINE 5 COLUMN 1 VALUE "------------------------------" - & "------------------------------". - - 05 LINE 7 COLUMN 1 VALUE "BLACK " FOREGROUND-COLOR BLACK. - 05 LINE + 1 COLUMN 1 VALUE "BLUE " FOREGROUND-COLOR BLUE. - 05 LINE + 1 COLUMN 1 VALUE "GREEN " FOREGROUND-COLOR GREEN. - 05 LINE + 1 COLUMN 1 VALUE "CYAN " FOREGROUND-COLOR CYAN. - 05 LINE + 1 COLUMN 1 VALUE "RED " FOREGROUND-COLOR RED. - 05 LINE + 1 COLUMN 1 VALUE "MAGENTA" FOREGROUND-COLOR MAGENTA. - 05 LINE + 1 COLUMN 1 VALUE "BROWN " FOREGROUND-COLOR BROWN. - 05 LINE + 1 COLUMN 1 VALUE "WHITE " FOREGROUND-COLOR WHITE. - *>BACKGROUND-COLOR BLACK. - - 05 LINE 7 COLUMN 16 VALUE "BLACK " - HIGHLIGHT FOREGROUND-COLOR BLACK. - *>BACKGROUND-COLOR WHITE. - 05 LINE + 1 COLUMN 16 VALUE "BLUE " - HIGHLIGHT FOREGROUND-COLOR BLUE. - 05 LINE + 1 COLUMN 16 VALUE "GREEN " - HIGHLIGHT FOREGROUND-COLOR GREEN. - 05 LINE + 1 COLUMN 16 VALUE "CYAN " - HIGHLIGHT FOREGROUND-COLOR CYAN. - 05 LINE + 1 COLUMN 16 VALUE "RED " - HIGHLIGHT FOREGROUND-COLOR RED. - 05 LINE + 1 COLUMN 16 VALUE "MAGENTA" - HIGHLIGHT FOREGROUND-COLOR MAGENTA. - 05 LINE + 1 COLUMN 16 VALUE "BROWN " - HIGHLIGHT FOREGROUND-COLOR BROWN. - 05 LINE + 1 COLUMN 16 VALUE "WHITE " - HIGHLIGHT FOREGROUND-COLOR WHITE - BACKGROUND-COLOR BLACK. - - 05 LINE 7 COLUMN 31 VALUE "BLACK " - LOWLIGHT FOREGROUND-COLOR BLACK. - *>BACKGROUND-COLOR WHITE. - 05 LINE + 1 COLUMN 31 VALUE "BLUE " - LOWLIGHT FOREGROUND-COLOR BLUE. - 05 LINE + 1 COLUMN 31 VALUE "GREEN " - LOWLIGHT FOREGROUND-COLOR GREEN. - 05 LINE + 1 COLUMN 31 VALUE "CYAN " - LOWLIGHT FOREGROUND-COLOR CYAN. - 05 LINE + 1 COLUMN 31 VALUE "RED " - LOWLIGHT FOREGROUND-COLOR RED. - 05 LINE + 1 COLUMN 31 VALUE "MAGENTA" - LOWLIGHT FOREGROUND-COLOR MAGENTA. - 05 LINE + 1 COLUMN 31 VALUE "BROWN " - LOWLIGHT FOREGROUND-COLOR BROWN. - 05 LINE + 1 COLUMN 31 VALUE "WHITE " - LOWLIGHT FOREGROUND-COLOR WHITE. - *>BACKGROUND-COLOR BLACK. - - 05 LINE 7 COLUMN 46 VALUE "BLACK " - REVERSE-VIDEO FOREGROUND-COLOR BLACK. - *>BACKGROUND-COLOR WHITE. - 05 LINE + 1 COLUMN 46 VALUE "BLUE " - REVERSE-VIDEO FOREGROUND-COLOR BLUE. - 05 LINE + 1 COLUMN 46 VALUE "GREEN " - REVERSE-VIDEO FOREGROUND-COLOR GREEN. - 05 LINE + 1 COLUMN 46 VALUE "CYAN " - REVERSE-VIDEO FOREGROUND-COLOR CYAN. - 05 LINE + 1 COLUMN 46 VALUE "RED " - REVERSE-VIDEO FOREGROUND-COLOR RED. - 05 LINE + 1 COLUMN 46 VALUE "MAGENTA" - REVERSE-VIDEO FOREGROUND-COLOR MAGENTA. - 05 LINE + 1 COLUMN 46 VALUE "BROWN " - REVERSE-VIDEO FOREGROUND-COLOR BROWN. - 05 LINE + 1 COLUMN 46 VALUE "WHITE " - REVERSE-VIDEO FOREGROUND-COLOR WHITE. - *>BACKGROUND-COLOR BLACK. - - *> 05 LINE 7 COLUMN 61 ERASE EOL. - *> 05 LINE + 1 COLUMN 61 ERASE EOL. - *> 05 LINE + 1 COLUMN 61 ERASE EOL. - *> 05 LINE + 1 COLUMN 61 ERASE EOL. - *> 05 LINE + 1 COLUMN 61 ERASE EOL. - *> 05 LINE + 1 COLUMN 61 ERASE EOL. - *> 05 LINE + 1 COLUMN 61 ERASE EOL. - *> 05 LINE + 1 COLUMN 61 ERASE EOL. - *> *************************************************************** - PROCEDURE DIVISION. - - MOVE ZERO TO CNTR. - * DISPLAY ' ' AT LINE 1 COLUMN 1. - CALL 'CBL_GC_SET_SCR_SIZE' USING 50, 80. - - * ACCEPT - * OMITTED - * LINE 16 COLUMN 1 - * END-ACCEPT. - - - DISPLAY ' YOU WILL SEE 4 WINDOWS OF ALTERNATING COLORS ' & - 'WAIT UNTIL THE END TO ANSWER-TEXT PROMPT' - AT LINE 1 COL 4. - - D DISPLAY ' ' UPON SYSERR - D DISPLAY ' STARTING NEW WINDOWS ' UPON SYSERR - D DISPLAY ' ' UPON SYSERR - - PERFORM 4 TIMES - ADD +5 TO CNTR - MOVE CNTR TO WP-WINDOW-START-ROW - MOVE CNTR TO WP-WINDOW-START-COL - MOVE 20 TO WP-WINDOW-ROWS - MOVE 60 TO WP-WINDOW-COLUMNS - IF SW-EVEN EQUAL 'Y' - MOVE 'N' TO SW-EVEN - MOVE 0 TO WP-WINDOW-FG-COLOR - MOVE 6 TO WP-WINDOW-BG-COLOR - ELSE - MOVE 'Y' TO SW-EVEN - MOVE 0 TO WP-WINDOW-FG-COLOR - MOVE 3 TO WP-WINDOW-BG-COLOR - END-IF - MOVE ZERO TO WP-WINDOW-HIDDEN - MOVE ZERO TO WP-WINDOW-RETURN-CODE - SET WP-MODE-NEW-WINDOW TO TRUE - PERFORM 1000-WINDOW-FUNCTION THRU 1000-EXIT - CALL 'CBL_GC_WINDOW' USING WL-WINDOW-LIST - PERFORM 3000-LIST-WINDOWS THRU 3000-EXIT - PERFORM 2000-WINDOW-CSR-POS THRU 2000-EXIT - DISPLAY GNUCOBOL-COLOURS - PERFORM 2000-WINDOW-CSR-POS THRU 2000-EXIT - CALL "C$SLEEP" USING 1 - END-PERFORM. - - - MOVE ZERO TO CNTR. - - D DISPLAY ' ' UPON SYSERR - D DISPLAY ' STARTING HIDE WINDOWS ' UPON SYSERR - D DISPLAY ' ' UPON SYSERR - - PERFORM 4 TIMES - ADD +1 TO CNTR - MOVE CNTR TO WP-WINDOW-NUMBER - MOVE 1 TO WP-WINDOW-HIDDEN - MOVE ZERO TO WP-WINDOW-RETURN-CODE - SET WP-MODE-HIDE-WINDOW TO TRUE - PERFORM 1000-WINDOW-FUNCTION THRU 1000-EXIT - CALL 'CBL_GC_WINDOW' USING WL-WINDOW-LIST - PERFORM 3000-LIST-WINDOWS THRU 3000-EXIT - CALL "C$SLEEP" USING 1 - END-PERFORM. - - - MOVE 5 TO CNTR. - - D DISPLAY ' ' UPON SYSERR - D DISPLAY ' STARTING SHOW WINDOWS ' UPON SYSERR - D DISPLAY ' ' UPON SYSERR - - PERFORM 4 TIMES - ADD -1 TO CNTR - MOVE CNTR TO WP-WINDOW-NUMBER - MOVE ZERO TO WP-WINDOW-HIDDEN - MOVE ZERO TO WP-WINDOW-RETURN-CODE - SET WP-MODE-SHOW-WINDOW TO TRUE - PERFORM 1000-WINDOW-FUNCTION THRU 1000-EXIT - CALL 'CBL_GC_WINDOW' USING WL-WINDOW-LIST - PERFORM 3000-LIST-WINDOWS THRU 3000-EXIT - CALL "C$SLEEP" USING 1 - PERFORM 2000-WINDOW-CSR-POS THRU 2000-EXIT - END-PERFORM. - - MOVE ZERO TO CNTR. - MOVE 10 TO CNTR-COL. - MOVE 10 TO CNTR-ROW. - - D DISPLAY ' ' UPON SYSERR - D DISPLAY ' STARTING MOVE WINDOWS ' UPON SYSERR - D DISPLAY ' STARTING TOP WINDOWS ' UPON SYSERR - D DISPLAY ' ' UPON SYSERR - - PERFORM 4 TIMES - PERFORM 2000-WINDOW-CSR-POS THRU 2000-EXIT - ADD +1 TO CNTR - ADD +2 TO CNTR-ROW - ADD +2 TO CNTR-COL - MOVE CNTR TO WP-WINDOW-NUMBER - MOVE CNTR-ROW TO WP-WINDOW-START-ROW - MOVE CNTR-COL TO WP-WINDOW-START-COL - MOVE 0 TO WP-WINDOW-HIDDEN - MOVE ZERO TO WP-WINDOW-RETURN-CODE - SET WP-MODE-MOVE-WINDOW TO TRUE - PERFORM 1000-WINDOW-FUNCTION THRU 1000-EXIT - CALL 'CBL_GC_WINDOW' USING WL-WINDOW-LIST - PERFORM 3000-LIST-WINDOWS THRU 3000-EXIT - MOVE CNTR TO WP-WINDOW-NUMBER - MOVE 0 TO WP-WINDOW-START-ROW - MOVE 0 TO WP-WINDOW-START-COL - MOVE 0 TO WP-WINDOW-HIDDEN - MOVE ZERO TO WP-WINDOW-RETURN-CODE - PERFORM 2000-WINDOW-CSR-POS THRU 2000-EXIT - SET WP-MODE-TOP-WINDOW TO TRUE - PERFORM 1000-WINDOW-FUNCTION THRU 1000-EXIT - PERFORM 2000-WINDOW-CSR-POS THRU 2000-EXIT - CALL "C$SLEEP" USING 1 - END-PERFORM. - - CALL "C$SLEEP" USING 1 - * ACCEPT - * OMITTED - * LINE 16 COLUMN 1 - * END-ACCEPT. - - MOVE ZERO TO CNTR. - - D DISPLAY ' ' UPON SYSERR - D DISPLAY ' STARTING BOTTOM WINDOWS ' UPON SYSERR - D DISPLAY ' ' UPON SYSERR - - PERFORM 4 TIMES - ADD +1 TO CNTR - MOVE CNTR TO WP-WINDOW-NUMBER - MOVE 1 TO WP-WINDOW-HIDDEN - MOVE ZERO TO WP-WINDOW-RETURN-CODE - SET WP-MODE-BOTTOM-WINDOW TO TRUE - PERFORM 1000-WINDOW-FUNCTION THRU 1000-EXIT - CALL 'CBL_GC_WINDOW' USING WL-WINDOW-LIST - PERFORM 3000-LIST-WINDOWS THRU 3000-EXIT - * CALL "C$SLEEP" USING 1 - END-PERFORM. - - MOVE ZERO TO CNTR. - - D DISPLAY ' ' UPON SYSERR - D DISPLAY ' STARTING DELETE WINDOWS ' UPON SYSERR - D DISPLAY ' ' UPON SYSERR - - PERFORM 4 TIMES - ADD +1 TO CNTR - MOVE CNTR TO WP-WINDOW-NUMBER - MOVE 1 TO WP-WINDOW-HIDDEN - MOVE ZERO TO WP-WINDOW-RETURN-CODE - SET WP-MODE-DELETE-WINDOW TO TRUE - PERFORM 1000-WINDOW-FUNCTION THRU 1000-EXIT - CALL 'CBL_GC_WINDOW' USING WL-WINDOW-LIST - PERFORM 3000-LIST-WINDOWS THRU 3000-EXIT - * CALL "C$SLEEP" USING 1 - END-PERFORM. - - DISPLAY ' DID YOU WILL SEE THEM CREATED, MOVED, HIDDEN, S' & - 'HOWN AND DELETED SUCCESSFULLY ?' - AT LINE 4 COL 4. - DISPLAY 'ANSWER Y OR N' - AT LINE 5 COL 10. - ACCEPT ANSWER-TEXT - AT LINE 5 COL 25. - - IF ANSWER-TEXT EQUAL 'Y' OR 'y' - MOVE ZERO TO RETURN-CODE - ELSE - MOVE 1 TO RETURN-CODE - END-IF. - - GOBACK. - - 1000-WINDOW-FUNCTION. - - CALL 'CBL_GC_WINDOW' USING WP-WINDOW-PARMS. - IF RETURN-CODE NOT EQUAL ZERO - D DISPLAY 'RETURN CODE IS ==> ' RETURN-CODE - D UPON SYSERR - MOVE 1 TO RETURN-CODE - GOBACK - END-IF. - - IF WP-WINDOW-RETURN-CODE NOT EQUAL ZERO - D DISPLAY 'WP-WINDOW-RETURN-CODE IS ==> ' - D WP-WINDOW-RETURN-CODE - D UPON SYSERR - MOVE 1 TO RETURN-CODE - GOBACK - END-IF. - - - 1000-EXIT. EXIT. - - 2000-WINDOW-CSR-POS. - - CALL "CBL_GET_CSR_POS" USING CURSOR-LOCN-BUFFER. - COMPUTE TMP-LINE = CURSOR-LINE + 1. - COMPUTE TMP-COLUMN = CURSOR-COLUMN + 1. - D DISPLAY ' WINDOW ==> ' WP-WINDOW-NUMBER - D ' CURSOR POSITION IS LINE ' - D TMP-LINE - D ' COLUMN ' - D TMP-COLUMN - D UPON SYSERR. - - 2000-EXIT. EXIT. - - 3000-LIST-WINDOWS. - - SET WL-INDEX TO +1. - D DISPLAY ' =========> START LISTING WINDOWS ' UPON SYSERR. - PERFORM 20 TIMES - IF WL-WINDOW (WL-INDEX) EQUAL LOW-VALUES - EXIT PERFORM - END-IF - D DISPLAY ' DEPTH => ' WL-DEPTH (WL-INDEX) - D ' NUMBER => ' WL-WINDOW-NUMBER (WL-INDEX) - D ' POS ROW => ' WL-WINDOW-POSITION-ROW (WL-INDEX) - D ' POS COL => ' WL-WINDOW-POSITION-COL (WL-INDEX) - D ' WIN ROW => ' WL-WINDOW-SIZE-ROW (WL-INDEX) - D ' WIN COL => ' WL-WINDOW-SIZE-COL (WL-INDEX) - D ' FG => ' WL-WINDOW-FG-COLOR (WL-INDEX) - D ' BG => ' WL-WINDOW-BG-COLOR (WL-INDEX) - D ' HIDDEN => ' WL-WINDOW-HIDDEN (WL-INDEX) - D UPON SYSERR - SET WL-INDEX UP BY +1 - END-PERFORM. - D DISPLAY ' =========> END LISTING WINDOWS ' UPON SYSERR. - - 3000-EXIT. EXIT. - END PROGRAM SAMPLE. -]) - -AT_CHECK([$COMPILE prog.cob], [0], [], []) -MANUAL_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) - -AT_CLEANUP +## Copyright (C) 2014-2018,2020-2024 Free Software Foundation, Inc. +## Written by Edward Hart, Simon Sobisch, Chuck Haatvedt +## +## This file is part of GnuCOBOL. +## +## The GnuCOBOL compiler is free software: you can redistribute it +## and/or modify it under the terms of the GNU General Public License +## as published by the Free Software Foundation, either version 3 of the +## License, or (at your option) any later version. +## +## GnuCOBOL is distributed in the hope that it will be useful, +## but WITHOUT ANY WARRANTY; without even the implied warranty of +## MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +## GNU General Public License for more details. +## +## You should have received a copy of the GNU General Public License +## along with GnuCOBOL. If not, see . + +### GnuCOBOL Test Suite + +### ISO+IEC+1989-2014 9.2 Screens, 13.17 Screen description entry, 13.18 Data +### division clauses. + +AT_SETUP([LINE]) +AT_KEYWORDS([screen]) + +AT_SKIP_IF([test "$COB_HAS_CURSES" != "yes"]) + +AT_DATA([prog.cob], [ + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 success-flag PIC X VALUE 'Y'. + 88 success VALUE 'Y', 'y'. + + SCREEN SECTION. + 01 scr. + 03 LINE 1 VALUE 'Enter "y" if the numbers below correspond ' + & 'to their line number and are in the '. + 03 LINE 2 VALUE 'first column. (This is line 2.)'. + 03 LINE 3 VALUE '3'. + 03 LINE 4 VALUE '4'. + 03 LINE 5 VALUE '5'. + 03 group-1 LINE - 3. + 05 group-2 COL 5. + 07 LINE PLUS 6 VALUE '8'. + 07 LINE MINUS 2 VALUE '6'. + 03 group-3 LINE + 1. + 05 COL 1 VALUE '7'. + 03 LINE + 3 PIC X, REQUIRED USING success-flag. + + PROCEDURE DIVISION. + DISPLAY scr + ACCEPT scr + + IF success AND COB-CRT-STATUS = 0 + GOBACK RETURNING 0 + ELSE + GOBACK RETURNING 1 + END-IF + . +]) + +AT_CHECK([$COMPILE prog.cob], [0], [], []) +MANUAL_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) + +AT_CLEANUP + + +AT_SETUP([COLUMN (1)]) +AT_KEYWORDS([COL]) + +AT_SKIP_IF([test "$COB_HAS_CURSES" != "yes"]) + +AT_DATA([prog.cob], [ + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 dummy PIC X(5). + 01 success-flag PIC X VALUE 'Y'. + 88 success VALUE 'Y', 'y'. + + SCREEN SECTION. + 01 scr. + 03 VALUE 'Enter "y" if the numbers below correspond to ' + & 'their column number.'. + 03 LINE 2 VALUE '123456789'. + 03 LINE 3 COLUMN 2. + 05 COL 1 VALUE '1'. + 05 COL 5 VALUE '5'. + 05 COL MINUS 2 VALUE '3'. + 05 COL PLUS 1 VALUE '4'. + 05 group-1 LINE 3. + 07 VALUE '2'. + 07 group-2 COLUMN + 4. + 09 group-3. + 11 COL + 0 VALUE '6'. + 05 COLUMN + 1, VALUE '7'. + 03 LINE 5 PIC X, REQUIRED, USING success-flag. + + PROCEDURE DIVISION. + DISPLAY scr + ACCEPT scr + + IF success AND COB-CRT-STATUS = 0 + GOBACK RETURNING 0 + ELSE + GOBACK RETURNING 1 + END-IF + . +]) + +AT_CHECK([$COMPILE prog.cob], [0], [], []) +MANUAL_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) + +AT_CLEANUP + + +AT_SETUP([COLUMN (2)]) +AT_KEYWORDS([COL]) + +AT_SKIP_IF([test "$COB_HAS_CURSES" != "yes"]) + +AT_DATA([prog.cob], [ + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 dummy-1 PIC X(10). + 01 dummy-2 PIC X(10). + 01 dummy-3 PIC X(10). + + 01 success-flag PIC X VALUE 'Y'. + 88 success VALUE 'Y', 'y'. + + SCREEN SECTION. + 01 scr. + 03 PIC X(80) VALUE 'Enter "y" if there are three non-'- + 'overlapping input fields on one line below.'. + 03 LINE + 1, PIC X(80) VALUE 'field.'. + 03 LINE + 2, PIC X(10) TO dummy-1. + 03 COL + 2, PIC X(10) TO dummy-2. + 03 COL + 2, PIC X(10) TO dummy-3. + 03 success-field LINE + 2, PIC X, REQUIRED, + USING success-flag. + + PROCEDURE DIVISION. + DISPLAY scr + ACCEPT scr + + IF success AND COB-CRT-STATUS = 0 + GOBACK RETURNING 0 + ELSE + GOBACK RETURNING 1 + END-IF + . +]) + +AT_CHECK([$COMPILE prog.cob], [0], [], []) +MANUAL_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) + +AT_CLEANUP + + +AT_SETUP([LINE non-zero, COLUMN zero]) +AT_KEYWORDS([COL extensions]) + +AT_SKIP_IF([test "$COB_HAS_CURSES" != "yes"]) + +AT_DATA([prog.cob], [ + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 success-flag PIC X VALUE 'Y'. + 88 success VALUE 'Y', 'y'. + + SCREEN SECTION. + 01 scr. + 03 LINE 1 VALUE 'Enter "y" if you see 123 on the line '- + 'below starting at column 1.'. + 03 LINE + 3 PIC X, REQUIRED USING success-flag. + 03 LINE 2 VALUE '1'. + + PROCEDURE DIVISION. + DISPLAY scr + DISPLAY '2' LINE 2, COLUMN 0; '3' + ACCEPT scr + + IF success AND COB-CRT-STATUS = 0 + GOBACK RETURNING 0 + ELSE + GOBACK RETURNING 1 + END-IF + . +]) + +AT_CHECK([$COMPILE prog.cob], [0], [], []) +MANUAL_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) + +AT_CLEANUP + + +AT_SETUP([LINE zero, COLUMN non-zero]) +AT_KEYWORDS([COL zero extensions]) + +AT_SKIP_IF([test "$COB_HAS_CURSES" != "yes"]) + +AT_DATA([prog.cob], [ + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 success-flag PIC X VALUE 'Y'. + 88 success VALUE 'Y', 'y'. + + SCREEN SECTION. + 01 scr. + 03 LINE 1 VALUE 'Enter "y" if you see 123 on the line '- + 'below starting at column 1.'. + 03 LINE + 3 PIC X, REQUIRED USING success-flag. + 03 LINE 2 COL 3, VALUE '3'. + 03 LINE 1 COL 80 VALUE ' '. + + PROCEDURE DIVISION. + DISPLAY scr + DISPLAY '1' LINE 0, COLUMN 1; '2' + ACCEPT scr + + IF success AND COB-CRT-STATUS = 0 + GOBACK RETURNING 0 + ELSE + GOBACK RETURNING 1 + END-IF + . +]) + +AT_CHECK([$COMPILE prog.cob], [0], [], []) +MANUAL_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) + +AT_CLEANUP + + +AT_SETUP([LINE zero, COLUMN zero]) +AT_KEYWORDS([COL extensions]) + +AT_SKIP_IF([test "$COB_HAS_CURSES" != "yes"]) + +AT_DATA([prog.cob], [ + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 success-flag PIC X VALUE 'Y'. + 88 success VALUE 'Y', 'y'. + + SCREEN SECTION. + 01 scr. + 03 LINE 1 VALUE 'Enter "y" if you see 1234 on the line '- + 'below starting at column 1.'. + 03 LINE + 3 PIC X, REQUIRED USING success-flag. + 03 LINE 2 VALUE '1'. + + PROCEDURE DIVISION. + DISPLAY scr + DISPLAY '2' LINE 0, COLUMN 0 + DISPLAY '3' LINE 2, COLUMN 3 + DISPLAY '4' AT 0000 + + ACCEPT scr + + IF success AND COB-CRT-STATUS = 0 + GOBACK RETURNING 0 + ELSE + GOBACK RETURNING 1 + END-IF + . +]) + +AT_CHECK([$COMPILE prog.cob], [0], [], []) +MANUAL_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) + +AT_CLEANUP + + +AT_SETUP([DISPLAY AT]) +AT_KEYWORDS([extensions]) + +AT_SKIP_IF([test "$COB_HAS_CURSES" != "yes"]) + +AT_DATA([prog.cob], [ + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 success-flag PIC X VALUE 'Y'. + 88 success VALUE 'Y', 'y'. + + 01 screen-loc PIC 9(6) VALUE 4004. + + SCREEN SECTION. + 01 scr. + 03 VALUE 'Enter "y" if the numbers 1-3 are in a diagonal'- + ' line from line 2, column 2.'. + 03 success-field PIC X, LINE 6, REQUIRED, + USING success-flag. + + PROCEDURE DIVISION. + DISPLAY '1' AT 0202 + DISPLAY '2' AT 003003 + DISPLAY '3' AT screen-loc + DISPLAY scr + ACCEPT scr + + IF success AND COB-CRT-STATUS = 0 + GOBACK RETURNING 0 + ELSE + GOBACK RETURNING 1 + END-IF + . +]) + +AT_CHECK([$COMPILE prog.cob], [0], [], []) +MANUAL_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) + +AT_CLEANUP + + +AT_SETUP([DISPLAY LOW-VALUES (one statement)]) +AT_KEYWORDS([LOW-VALUE extensions]) + +AT_SKIP_IF([test "$COB_HAS_CURSES" != "yes"]) + +AT_DATA([prog.cob], [ + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 success-flag PIC X VALUE 'Y'. + 88 success VALUE 'Y', 'y'. + + SCREEN SECTION. + 01 scr. + 03 LINE 1 VALUE 'Enter "y" if the word below starts at line' + & ' 3, column 3.'. + 03 LINE + 4 PIC X, REQUIRED USING success-flag. + + PROCEDURE DIVISION. + DISPLAY scr + DISPLAY LOW-VALUES AT LINE 3, COL 3; 'Hello!' + ACCEPT scr + + IF success AND COB-CRT-STATUS = 0 + GOBACK RETURNING 0 + ELSE + GOBACK RETURNING 1 + END-IF + . +]) + +AT_CHECK([$COMPILE prog.cob], [0], [], []) +MANUAL_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) + +AT_CLEANUP + + +AT_SETUP([DISPLAY LOW-VALUES (two statements)]) +AT_KEYWORDS([LOW-VALUE extensions]) + +AT_SKIP_IF([test "$COB_HAS_CURSES" != "yes"]) + +AT_DATA([prog.cob], [ + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 success-flag PIC X VALUE 'Y'. + 88 success VALUE 'Y', 'y'. + + SCREEN SECTION. + 01 scr. + 03 LINE 1 VALUE 'Enter "y" if the word below starts at line' + & ' 3, column 3.'. + 03 LINE + 4 PIC X, REQUIRED USING success-flag. + + PROCEDURE DIVISION. + DISPLAY scr + DISPLAY LOW-VALUES AT LINE 3, COL 3 + DISPLAY 'Hello!' UPON CRT + ACCEPT scr + + IF success AND COB-CRT-STATUS = 0 + GOBACK RETURNING 0 + ELSE + GOBACK RETURNING 1 + END-IF + . +]) + +AT_CHECK([$COMPILE prog.cob], [0], [], []) +MANUAL_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) + +AT_CLEANUP + + +AT_SETUP([DISPLAY SPACES]) +AT_KEYWORDS([SPACE extensions]) + +AT_SKIP_IF([test "$COB_HAS_CURSES" != "yes"]) + +AT_DATA([prog.cob], [ + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 success-flag PIC X VALUE 'Y'. + 88 success VALUE 'Y', 'y'. + + SCREEN SECTION. + 01 scr-1. + 03 LINE 1 VALUE 'Enter "y" if all the text after foo in the' + & ' screen has been erased.'. + 03 LINE 3 VALUE 'Lorem ipsum dolor sit amet, consectetur ad' + & 'ipiscing elit. Curabitur dapibus dui'. + 03 LINE 4 VALUE 'vitae augue lobortis, non tempor diam tris' + & 'tique. Donec dignissim ex velit, ut'. + 03 LINE 5 VALUE 'efficitur tellus pharetra at. Curabitur at' + & ' condimentum nunc, nec accumsan'. + 03 LINE 6 VALUE 'nulla. Nulla at feugiat elit, eget condime' + & 'ntum justo. Nam lorem lectus,'. + 03 LINE 7 VALUE 'imperdiet sit amet odio eu, eleifend conse' + & 'ctetur ligula. Duis diam felis, porta'. + 03 LINE 8 VALUE 'id diam id, ultrices finibus augue. Mauris' + & ' imperdiet, dolor sed sodales porta,'. + 03 LINE 9 VALUE 'justo nunc consequat nulla, iaculis venena' + & 'tis lorem libero sit amet'. + 03 LINE 10 VALUE 'magna. Nullam pulvinar nullam.'. + 03 success-field LINE + 2, PIC X, REQUIRED, + USING success-flag. + + PROCEDURE DIVISION. + DISPLAY scr-1 + DISPLAY SPACES AT LINE 6, COL 8; 'foo' HIGHLIGHT + ACCEPT success-field + + IF success AND COB-CRT-STATUS = 0 + GOBACK RETURNING 0 + ELSE + GOBACK RETURNING 1 + END-IF + . +]) + +AT_CHECK([$COMPILE -fdisplay-special-fig-consts prog.cob], [0], [], []) +MANUAL_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) + +AT_CLEANUP + + +AT_SETUP([DISPLAY ALL X'01']) +AT_KEYWORDS([SOH extensions]) + +AT_SKIP_IF([test "$COB_HAS_CURSES" != "yes"]) + +AT_DATA([prog.cob], [ + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 success-flag PIC X VALUE 'Y'. + 88 success VALUE 'Y', 'y'. + + SCREEN SECTION. + 01 scr-1. + 03 LINE 1 VALUE 'Enter "y" if all the text after foo on ' + & 'that line alone has been erased.'. + 03 LINE 3 VALUE 'Lorem ipsum dolor sit amet, consectetur ad' + & 'ipiscing elit. Curabitur dapibus dui'. + 03 LINE 4 VALUE 'vitae augue lobortis, non tempor diam tris' + & 'tique. Donec dignissim ex velit, ut'. + 03 LINE 5 VALUE 'efficitur tellus pharetra at. Curabitur at' + & ' condimentum nunc, nec accumsan'. + 03 LINE 6 VALUE 'nulla. Nulla at feugiat elit, eget condime' + & 'ntum justo. Nam lorem lectus,'. + 03 LINE 7 VALUE 'imperdiet sit amet odio eu, eleifend conse' + & 'ctetur ligula. Duis diam felis, porta'. + 03 LINE 8 VALUE 'id diam id, ultrices finibus augue. Mauris' + & ' imperdiet, dolor sed sodales porta,'. + 03 LINE 9 VALUE 'justo nunc consequat nulla, iaculis venena' + & 'tis lorem libero sit amet'. + 03 LINE 10 VALUE 'magna. Nullam pulvinar nullam.'. + 03 success-field LINE + 2, PIC X, REQUIRED, + USING success-flag. + + PROCEDURE DIVISION. + DISPLAY scr-1 + DISPLAY ALL X'01', LINE 6, COLUMN 8; 'foo' HIGHLIGHT + ACCEPT success-field + + IF success AND COB-CRT-STATUS = 0 + GOBACK RETURNING 0 + ELSE + GOBACK RETURNING 1 + END-IF + . +]) + +AT_CHECK([$COMPILE -fdisplay-special-fig-consts prog.cob], [0], [], []) +MANUAL_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) + +AT_CLEANUP + + +AT_SETUP([DISPLAY ALL X'02']) +AT_KEYWORDS([STX extensions]) + +AT_SKIP_IF([test "$COB_HAS_CURSES" != "yes"]) + +AT_DATA([prog.cob], [ + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 success-flag PIC X VALUE 'Y'. + 88 success VALUE 'Y', 'y'. + + SCREEN SECTION. + 01 scr-1. + 03 LINE 3 VALUE 'Lorem ipsum dolor sit amet, consectetur ad' + & 'ipiscing elit. Curabitur dapibus dui'. + 03 LINE 4 VALUE 'vitae augue lobortis, non tempor diam tris' + & 'tique. Donec dignissim ex velit, ut'. + 03 LINE 5 VALUE 'efficitur tellus pharetra at. Curabitur at' + & ' condimentum nunc, nec accumsan'. + 03 LINE 6 VALUE 'nulla. Nulla at feugiat elit, eget condime' + & 'ntum justo. Nam lorem lectus,'. + 03 LINE 7 VALUE 'imperdiet sit amet odio eu, eleifend conse' + & 'ctetur ligula. Duis diam felis, porta'. + 03 LINE 8 VALUE 'id diam id, ultrices finibus augue. Mauris' + & ' imperdiet, dolor sed sodales porta,'. + 03 LINE 9 VALUE 'justo nunc consequat nulla, iaculis venena' + & 'tis lorem libero sit amet'. + 03 LINE 10 VALUE 'magna. Nullam pulvinar nullam.'. + + 01 scr-2. + 03 LINE 6 COL 8 VALUE 'foo' BLANK SCREEN, HIGHLIGHT. + 03 LINE 1 VALUE 'Enter "y" if foo is the only word below.'. + + 01 scr-3. + 03 VALUE 'Enter "y" if foo is the only word below.'. + 03 success-field COL + 2, PIC X, REQUIRED, + USING success-flag. + + PROCEDURE DIVISION. + DISPLAY scr-1 + DISPLAY ALL X'02' AT LINE 6 COL 8; 'foo' HIGHLIGHT + DISPLAY scr-3 + ACCEPT scr-3 + + IF success AND COB-CRT-STATUS = 0 + GOBACK RETURNING 0 + ELSE + GOBACK RETURNING 1 + END-IF + . +]) + +AT_CHECK([$COMPILE -fdisplay-special-fig-consts prog.cob], [0], [], []) +MANUAL_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) + +AT_CLEANUP + + +AT_SETUP([DISPLAY ALL X'07']) +AT_KEYWORDS([BELL BEEP extensions]) + +AT_SKIP_IF([test "$COB_HAS_CURSES" != "yes"]) + +AT_DATA([prog.cob], [ + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 success-flag PIC X. + 88 success VALUE 'Y', 'y'. + + SCREEN SECTION. + 01 scr. + 03 VALUE 'Enter "y" if you heard a beep:'. + 03 success-field PIC X, COL + 2, REQUIRED, TO success-flag + FROM 'Y'. + 01 scr2. + 03 LINE 4 VALUE 'system beep may be turned off ' & + 'on this system.'. + 03 LINE 5 VALUE 'Retesting with COB_BELL=FLASH...'. + 03 LINE + 2 + VALUE 'Enter "y" if you''ve seen your terminal flash'. + 03 success-field PIC X, COL + 2, REQUIRED, TO success-flag + FROM 'Y'. + + PROCEDURE DIVISION. + DISPLAY scr + DISPLAY ALL X'07' UPON CRT + ACCEPT scr + + IF success AND COB-CRT-STATUS = 0 + GOBACK RETURNING 0 + END-IF + + SET ENVIRONMENT 'COB_BELL' TO 'FLASH' + CALL 'C$SLEEP' USING '1' + + DISPLAY scr2 + DISPLAY ALL X'07' UPON CRT + ACCEPT scr2 + + IF success AND COB-CRT-STATUS = 0 + GOBACK RETURNING 0 + ELSE + GOBACK RETURNING 1 + END-IF + . +]) + +AT_CHECK([$COMPILE -fdisplay-special-fig-consts prog.cob], [0], [], []) +MANUAL_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) + +AT_CLEANUP + + +AT_SETUP([Screen position after field display]) +AT_KEYWORDS([LINE COLUMN]) + +AT_SKIP_IF([test "$COB_HAS_CURSES" != "yes"]) + +AT_DATA([prog.cob], [ + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 success-flag PIC X VALUE 'Y'. + 88 success VALUE 'Y', 'y'. + + SCREEN SECTION. + 01 scr. + 03 VALUE 'Enter "y" if this sentence starts at line 1,'- + ' column 1:'. + 03 success-field PIC X, COL + 2, REQUIRED, + USING success-flag. + + PROCEDURE DIVISION. + DISPLAY 'ignore this' AT LINE 4 COL 4 + DISPLAY scr + ACCEPT success-field + + IF success AND COB-CRT-STATUS = 0 + GOBACK RETURNING 0 + ELSE + GOBACK RETURNING 1 + END-IF + . +]) + +AT_CHECK([$COMPILE prog.cob], [0], [], []) +MANUAL_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) + +AT_CLEANUP + +# See section 13.17.3 + +AT_SETUP([Overridden clauses (1)]) +AT_KEYWORDS([LINE COLUMN COL]) + +AT_SKIP_IF([test "$COB_HAS_CURSES" != "yes"]) + +AT_DATA([prog.cob], [ + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 dummy PIC X(5). + 01 success-flag PIC X VALUE 'Y'. + 88 success VALUE 'Y', 'y'. + + SCREEN SECTION. + 01 scr. + 03 VALUE 'Enter "y" if the numbers below correspond to their' + & ' column number and all on'. + 03 LINE 2 VALUE 'lines 3 and 4.'. + 03 LINE 3 VALUE '123456789'. + 03 LINE 4 VALUE ' 34'. + 03 FILLER LINE + 6. + 05 COL 3. + 07 COL 1. + 09 LINE 4 VALUE '1'. + 09 VALUE '2'. + 05 LINE + 1, COL + 2. + 07 LINE 4, COL + 1, VALUE '5'. + 03 LINE 6 PIC X, REQUIRED, USING success-flag. + + PROCEDURE DIVISION. + DISPLAY scr + ACCEPT scr + + IF success AND COB-CRT-STATUS = 0 + GOBACK RETURNING 0 + ELSE + GOBACK RETURNING 1 + END-IF + . +]) + +AT_CHECK([$COMPILE prog.cob], [0], [], []) +MANUAL_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) + +AT_CLEANUP + + +AT_SETUP([Overridden clauses (2)]) +AT_KEYWORDS([HIGHLIGHT LOWLIGHT BACKGROUND COLOR COLOUR]) + +AT_SKIP_IF([test "$COB_HAS_CURSES" != "yes"]) + +AT_DATA([prog.cob], [ + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 dummy PIC X(5). + 01 success-flag PIC X VALUE 'Y'. + 88 success VALUE 'Y', 'y'. + + SCREEN SECTION. + 01 scr. + 03 VALUE 'Enter "y" if the word below is not dim and has' + & ' black background.'. + 03 LINE + 1, LOWLIGHT BACKGROUND-COLOR 3. + 05 HIGHLIGHT BACKGROUND-COLOR 0. + 07 VALUE 'Highlight'. + 03 LINE + 2, PIC X USING success-flag. + + PROCEDURE DIVISION. + DISPLAY scr + ACCEPT scr + + IF success AND COB-CRT-STATUS = 0 + GOBACK RETURNING 0 + ELSE + GOBACK RETURNING 1 + END-IF + . +]) + +AT_CHECK([$COMPILE prog.cob], [0], [], []) +MANUAL_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) + +AT_CLEANUP + + +AT_SETUP([AUTO]) +AT_KEYWORDS([position]) + +AT_SKIP_IF([test "$COB_HAS_CURSES" != "yes"]) + +AT_DATA([prog.cob], [ + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 dummy PIC X(5). + 01 success-flag PIC X. + 88 success VALUE 'Y', 'y'. + + SCREEN SECTION. + 01 scr. + 03 PIC X(80) VALUE 'Enter "y" in the bottom' + & ' field if:'. + 03 LINE + 1, PIC X(80) VALUE ' * when the left field is' + & ' full, the cursor automatically moves'. + 03 LINE + 1, PIC X(80) VALUE ' to the next field.'. + 03 LINE + 1, PIC X(80) VALUE ' * this does not happen' + & ' with the other fields.'. + 03 LINE + 1, PIC X(80) VALUE ' * the fields below are' + & ' on one line and separated by a single' + & ' column.'. + + 03 test-fields LINE + 2. + 05 field-1 COL 1, PIC X(5) AUTO TO dummy. + 05 field-2 COL + 2, PIC X(5) TO dummy. + 05 field-3 COL + 2, PIC X(5) TO dummy. + 03 success-field LINE + 2, COLUMN 1; PIC X, REQUIRED + TO success-flag FROM 'Y'. + + PROCEDURE DIVISION. + DISPLAY scr + ACCEPT scr + + IF success AND COB-CRT-STATUS = 0 + GOBACK RETURNING 0 + ELSE + GOBACK RETURNING 1 + END-IF + . +]) + +AT_CHECK([$COMPILE prog.cob], [0], [], []) +MANUAL_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) + +AT_CLEANUP + + +AT_SETUP([SCREEN BACKGROUND- / FOREGROUND-COLOUR]) +AT_KEYWORDS([BACKGROUND-COLOR BACKGROUND-COLOUR FOREGROUND-COLOR +COLOR COLOUR HIGHLIGHT BLINK]) + +AT_SKIP_IF([test "$COB_HAS_CURSES" != "yes"]) + +AT_DATA([prog.cob], [ + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 dummy PIC X(10). + 01 success-flag PIC X. + 88 success VALUE 'Y', 'y'. + + SCREEN SECTION. + 01 scr. + 03 PIC X(80) + VALUE 'Enter "y" if the text below matches the colour ' + & 'of the background/text.'. + 03 LINE + 1, COL 1, PIC X(80) + VALUE 'Note: the black text is on white background/the ' + & 'white background has black text'. + 03 LINE + 1, COL 1, PIC X(80) + VALUE 'to make the text visible.'. + + 03 LINE + 1. + 05 COL 1, PIC X(08) VALUE 'Black' FOREGROUND-COLOR 0 + BACKGROUND-COLOR 7. + 05 COL + 2, PIC X(08) VALUE 'Blue' FOREGROUND-COLOR 1. + 05 COL + 2, PIC X(08) VALUE 'Green' FOREGROUND-COLOR 2. + 05 COL + 2, PIC X(08) VALUE 'Cyan' FOREGROUND-COLOR 3. + 05 COL + 2, PIC X(08) VALUE 'Red' FOREGROUND-COLOR 4. + 05 COL + 2, PIC X(08) VALUE 'Magenta' FOREGROUND-COLOR 5. + 05 COL + 2, PIC X(15) VALUE 'Brown/Yellow' + FOREGROUND-COLOR 6. + 05 COL + 2, PIC X(08) VALUE 'White' FOREGROUND-COLOR 7. + + 03 LINE + 1. + 05 COL 1, PIC X(08) VALUE 'Black' BACKGROUND-COLOR 0 + FOREGROUND-COLOR 7. + 05 COL + 2, PIC X(08) VALUE 'Blue' BACKGROUND-COLOR 1. + 05 COL + 2, PIC X(08) VALUE 'Green' BACKGROUND-COLOR 2. + 05 COL + 2, PIC X(08) VALUE 'Cyan' BACKGROUND-COLOR 3. + 05 COL + 2, PIC X(08) VALUE 'Red' BACKGROUND-COLOR 4. + 05 COL + 2, PIC X(08) VALUE 'Magenta' BACKGROUND-COLOR 5. + 05 COL + 2, PIC X(15) VALUE 'Brown/Yellow' + BACKGROUND-COLOR 6. + 05 COL + 2, PIC X(08) VALUE 'White' BACKGROUND-COLOR 7 + FOREGROUND-COLOR 0. + + 03 LINE + 2. + 03 PIC X(80) + VALUE 'The following is the same as above, ' + & 'with "extended" attributes set;'. + 03 LINE + 1, COL 1, PIC X(80) + VALUE 'this should have the same effect as otherwise ' + & 'highlighted for the first line'. + 03 LINE + 1, COL 1, PIC X(80) + VALUE 'and blinking for the second one.'. + + 03 LINE + 1. + 05 COL 1, PIC X(08) VALUE 'Black' FOREGROUND-COLOR 8 + BACKGROUND-COLOR 0. + 05 COL + 2, PIC X(08) VALUE 'Blue' FOREGROUND-COLOR 9. + 05 COL + 2, PIC X(08) VALUE 'Green' FOREGROUND-COLOR 10. + 05 COL + 2, PIC X(08) VALUE 'Cyan' FOREGROUND-COLOR 11. + 05 COL + 2, PIC X(08) VALUE 'Red' FOREGROUND-COLOR 12. + 05 COL + 2, PIC X(08) VALUE 'Magenta' FOREGROUND-COLOR 13. + 05 COL + 2, PIC X(15) VALUE 'Brown/Yellow' + FOREGROUND-COLOR 14. + 05 COL + 2, PIC X(08) VALUE 'White' FOREGROUND-COLOR 15. + + 03 LINE + 1. + 05 COL 1, PIC X(08) VALUE 'Black' BACKGROUND-COLOR 8 + FOREGROUND-COLOR 15. + 05 COL + 2, PIC X(08) VALUE 'Blue' BACKGROUND-COLOR 9. + 05 COL + 2, PIC X(08) VALUE 'Green' BACKGROUND-COLOR 10. + 05 COL + 2, PIC X(08) VALUE 'Cyan' BACKGROUND-COLOR 11. + 05 COL + 2, PIC X(08) VALUE 'Red' BACKGROUND-COLOR 12. + 05 COL + 2, PIC X(08) VALUE 'Magenta' BACKGROUND-COLOR 13. + 05 COL + 2, PIC X(15) VALUE 'Brown/Yellow' + BACKGROUND-COLOR 14. + 05 COL + 2, PIC X(08) VALUE 'White' BACKGROUND-COLOR 15 + FOREGROUND-COLOR 8. + + 03 success-field LINE + 2, COL 1, PIC X, REQUIRED, + TO success-flag FROM 'Y'. + + PROCEDURE DIVISION. + DISPLAY scr + ACCEPT scr + + IF success AND COB-CRT-STATUS = 0 + GOBACK RETURNING 0 + ELSE + GOBACK RETURNING 1 + END-IF + . +]) + +AT_CHECK([$COMPILE prog.cob], [0], [], []) +MANUAL_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) + +AT_CLEANUP + + +AT_SETUP([SCREEN BACKGROUND- / FOREGROUND-COLOUR via COLOR]) +AT_KEYWORDS([BACKGROUND-COLOR BACKGROUND-COLOUR FOREGROUND-COLOR +COLOR COLOUR REVERSED]) + +# Currently not implemented +AT_XFAIL_IF([true]) + +AT_SKIP_IF([test "$COB_HAS_CURSES" != "yes"]) + +AT_DATA([prog.cob], [ + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 dummy PIC X(10). + 01 success-flag PIC X. + 88 success VALUE 'Y', 'y'. + 77 CBLACK PIC 9(05) VALUE 1. + 77 CBLUE PIC 9(05) VALUE 2. + 77 CGREEN PIC 9(05) VALUE 3. + 77 CCYAN PIC 9(05) VALUE 4. + 77 CRED PIC 9(05) VALUE 5. + 77 CMAGENTA PIC 9(05) VALUE 6. + 77 CYELLOW PIC 9(05) VALUE 7. + 77 CWHITE PIC 9(05) VALUE 8. + + SCREEN SECTION. + 01 scr. + 03 PIC X(80) + VALUE 'Enter "y" if the text below matches the colour ' + & 'of the background/text.'. + 03 LINE + 1, COL 1, PIC X(80) + VALUE 'Note: the black text is on white background/the ' + & 'white background has black text'. + 03 LINE + 1, COL 1, PIC X(80) + VALUE 'to make the text visible.'. + + 03 LINE + 1. + 05 COL 1, PIC X(08) VALUE 'Black' COLOR CBLACK. + 05 COL + 2, PIC X(08) VALUE 'Blue' COLOR CBLUE. + 05 COL + 2, PIC X(08) VALUE 'Green' COLOR CGREEN. + 05 COL + 2, PIC X(08) VALUE 'Cyan' COLOR CCYAN. + 05 COL + 2, PIC X(08) VALUE 'Red' COLOR CRED. + 05 COL + 2, PIC X(08) VALUE 'Magenta' COLOR CMAGENTA. + 05 COL + 2, PIC X(15) VALUE 'Brown/Yellow' + COLOR CYELLOW. + 05 COL + 2, PIC X(08) VALUE 'White' COLOR CWHITE. + + 01 scr2. + 03 LINE 5. + 05 COL 1, PIC X(08) VALUE 'Black' BACKGROUND-COLOR 0 + FOREGROUND-COLOR 7. + 05 COL + 2, PIC X(08) VALUE 'Blue' BACKGROUND-COLOR 1. + 05 COL + 2, PIC X(08) VALUE 'Green' BACKGROUND-COLOR 2. + 05 COL + 2, PIC X(08) VALUE 'Cyan' BACKGROUND-COLOR 3. + 05 COL + 2, PIC X(08) VALUE 'Red' BACKGROUND-COLOR 4. + 05 COL + 2, PIC X(08) VALUE 'Magenta' BACKGROUND-COLOR 5. + 05 COL + 2, PIC X(15) VALUE 'Brown/Yellow' + BACKGROUND-COLOR 6. + 05 COL + 2, PIC X(08) VALUE 'White' BACKGROUND-COLOR 7 + FOREGROUND-COLOR 0. + + 03 success-field LINE + 2, COL 1, PIC X, REQUIRED, + TO success-flag FROM 'Y'. + + PROCEDURE DIVISION. + ADD 256 TO CBLACK + DISPLAY scr + ADD 1024 TO CBLACK, CBLUE, CGREEN, CCYAN, + CRED, CMAGENTA, CYELLOW, CWHITE + DISPLAY scr2 + ACCEPT scr + + IF success AND COB-CRT-STATUS = 0 + GOBACK RETURNING 0 + ELSE + GOBACK RETURNING 1 + END-IF + . +]) + +AT_CHECK([$COMPILE prog.cob], [0], [], []) +MANUAL_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) + +AT_CLEANUP + + +AT_SETUP([field BACKGROUND- / FOREGROUND-COLOUR]) +AT_KEYWORDS([BACKGROUND-COLOR BACKGROUND-COLOUR FOREGROUND-COLOR +COLOR COLOUR HIGHLIGHT BLINK]) + +AT_SKIP_IF([test "$COB_HAS_CURSES" != "yes"]) + +AT_DATA([prog.cob], [ + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 dummy PIC X(10). + 01 success-flag PIC X. + 88 success VALUE 'Y', 'y'. + + SCREEN SECTION. + 01 scr. + 03 PIC X(80) + VALUE 'Enter "y" if the text below matches the colour ' + & 'of the background/text.'. + 03 LINE + 1, COL 1, PIC X(80) + VALUE 'Note: the black text is on white background/the ' + & 'white background has black text'. + 03 LINE + 1, COL 1, PIC X(80) + VALUE 'to make the text visible.'. + + 03 LINE + 1. + 05 COL 1, PIC X(08) VALUE 'Black' FOREGROUND-COLOR 0 + BACKGROUND-COLOR 7. + 05 COL + 2, PIC X(08) VALUE 'Blue' FOREGROUND-COLOR 1. + 05 COL + 2, PIC X(08) VALUE 'Green' FOREGROUND-COLOR 2. + 05 COL + 2, PIC X(08) VALUE 'Cyan' FOREGROUND-COLOR 3. + 05 COL + 2, PIC X(08) VALUE 'Red' FOREGROUND-COLOR 4. + 05 COL + 2, PIC X(08) VALUE 'Magenta' FOREGROUND-COLOR 5. + 05 COL + 2, PIC X(15) VALUE 'Brown/Yellow' + FOREGROUND-COLOR 6. + 05 COL + 2, PIC X(08) VALUE 'White' FOREGROUND-COLOR 7. + + 03 LINE + 1. + 05 COL 1, PIC X(08) VALUE 'Black' BACKGROUND-COLOR 0 + FOREGROUND-COLOR 7. + 05 COL + 2, PIC X(08) VALUE 'Blue' BACKGROUND-COLOR 1. + 05 COL + 2, PIC X(08) VALUE 'Green' BACKGROUND-COLOR 2. + 05 COL + 2, PIC X(08) VALUE 'Cyan' BACKGROUND-COLOR 3. + 05 COL + 2, PIC X(08) VALUE 'Red' BACKGROUND-COLOR 4. + 05 COL + 2, PIC X(08) VALUE 'Magenta' BACKGROUND-COLOR 5. + 05 COL + 2, PIC X(15) VALUE 'Brown/Yellow' + BACKGROUND-COLOR 6. + 05 COL + 2, PIC X(08) VALUE 'White' BACKGROUND-COLOR 7 + FOREGROUND-COLOR 0. + + 03 LINE + 2. + 03 PIC X(80) + VALUE 'The following is the same as above, ' + & 'with "extended" attributes set;'. + 03 LINE + 1, COL 1, PIC X(80) + VALUE 'this should have the same effect as otherwise ' + & 'highlighted for the first line'. + 03 LINE + 1, COL 1, PIC X(80) + VALUE 'and blinking for the second one.'. + + 03 LINE + 1. + 05 COL 1, PIC X(08) VALUE 'Black' FOREGROUND-COLOR 8 + BACKGROUND-COLOR 0. + 05 COL + 2, PIC X(08) VALUE 'Blue' FOREGROUND-COLOR 9. + 05 COL + 2, PIC X(08) VALUE 'Green' FOREGROUND-COLOR 10. + 05 COL + 2, PIC X(08) VALUE 'Cyan' FOREGROUND-COLOR 11. + 05 COL + 2, PIC X(08) VALUE 'Red' FOREGROUND-COLOR 12. + 05 COL + 2, PIC X(08) VALUE 'Magenta' FOREGROUND-COLOR 13. + 05 COL + 2, PIC X(15) VALUE 'Brown/Yellow' + FOREGROUND-COLOR 14. + 05 COL + 2, PIC X(08) VALUE 'White' FOREGROUND-COLOR 15. + + 03 LINE + 1. + 05 COL 1, PIC X(08) VALUE 'Black' BACKGROUND-COLOR 8 + FOREGROUND-COLOR 15. + 05 COL + 2, PIC X(08) VALUE 'Blue' BACKGROUND-COLOR 9. + 05 COL + 2, PIC X(08) VALUE 'Green' BACKGROUND-COLOR 10. + 05 COL + 2, PIC X(08) VALUE 'Cyan' BACKGROUND-COLOR 11. + 05 COL + 2, PIC X(08) VALUE 'Red' BACKGROUND-COLOR 12. + 05 COL + 2, PIC X(08) VALUE 'Magenta' BACKGROUND-COLOR 13. + 05 COL + 2, PIC X(15) VALUE 'Brown/Yellow' + BACKGROUND-COLOR 14. + 05 COL + 2, PIC X(08) VALUE 'White' BACKGROUND-COLOR 15 + FOREGROUND-COLOR 8. + + 03 success-field LINE + 2, COL 1, PIC X, REQUIRED, + TO success-flag FROM 'Y'. + + PROCEDURE DIVISION. + DISPLAY scr + ACCEPT scr + + IF success AND COB-CRT-STATUS = 0 + GOBACK RETURNING 0 + ELSE + GOBACK RETURNING 1 + END-IF + . +]) + +AT_CHECK([$COMPILE prog.cob], [0], [], []) +MANUAL_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) + +AT_CLEANUP + + +AT_SETUP([field BACKGROUND- / FOREGROUND-COLOUR via COLOR]) +AT_KEYWORDS([BACKGROUND-COLOR BACKGROUND-COLOUR FOREGROUND-COLOR +COLOR COLOUR REVERSED HIGHLIGHT BLINK]) + +AT_SKIP_IF([test "$COB_HAS_CURSES" != "yes"]) + +AT_DATA([prog.cob], [ + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 success-flag PIC X VALUE 'Y'. + 88 success VALUE 'Y', 'y'. + + 77 CBLACK PIC 9(05) COMP-5 VALUE 1. + 77 CBLUE PIC 9(05) COMP-5 VALUE 2. + 77 CGREEN PIC 9(05) COMP-5 VALUE 3. + 77 CCYAN PIC 9(05) COMP-5 VALUE 4. + 77 CRED PIC 9(05) COMP-5 VALUE 5. + 77 CMAGENTA PIC 9(05) COMP-5 VALUE 6. + 77 CYELLOW PIC 9(05) COMP-5 VALUE 7. + 77 CWHITE PIC 9(05) COMP-5 VALUE 8. + + 77 LIN PIC 99 COMP-5. + + 01 scr1 PIC X(80) + VALUE 'Enter "y" if the text below matches the colour ' + & 'of the background/text.'. + 01 scr2 PIC X(80) + VALUE 'Note: the black text is on white background/the ' + & 'white background has black text'. + 01 scr3 PIC X(80) + VALUE 'to make the text visible.'. + 01 scr8 PIC X(80) + VALUE 'following lines should be identical but ' + & 'highlighted for the first line'. + 01 scr9 PIC X(80) + VALUE 'and blinking for the second one.'. + + 01 scrblack PIC X(08) VALUE 'Black'. + 01 scrblue PIC X(08) VALUE 'Blue'. + 01 scrgreen PIC X(08) VALUE 'Green'. + 01 scrcyan PIC X(08) VALUE 'Cyan'. + 01 scrred PIC X(08) VALUE 'Red'. + 01 scrmaggy PIC X(08) VALUE 'Magenta'. + 01 scryell PIC X(14) VALUE 'Brown/Yellow'. + 01 scrwhite PIC X(08) VALUE 'White'. + + PROCEDURE DIVISION. + testme. + ADD 256 TO CBLACK + DISPLAY scr1 AT 0102 + DISPLAY scr2 AT 0202 + DISPLAY scr3 AT 0303 + MOVE 5 TO LIN + PERFORM dspcol + ADD 1024 TO CBLACK, CBLUE, CGREEN, CCYAN, + CRED, CMAGENTA, CYELLOW, CWHITE + MOVE 6 TO LIN + PERFORM dspcol + SUBTRACT 1024 FROM CBLACK, CBLUE, CGREEN, CCYAN, + CRED, CMAGENTA, CYELLOW, CWHITE + * + DISPLAY scr8 AT 0802 + DISPLAY scr9 AT 0903 + ADD 4096 TO CBLACK, CBLUE, CGREEN, CCYAN, + CRED, CMAGENTA, CYELLOW, CWHITE + MOVE 11 TO LIN + PERFORM dspcol + SUBTRACT 4096 FROM CBLACK, CBLUE, CGREEN, CCYAN, + CRED, CMAGENTA, CYELLOW, CWHITE + ADD 1024, 16384 TO CBLACK, CBLUE, CGREEN, CCYAN, + CRED, CMAGENTA, CYELLOW, CWHITE + MOVE 12 TO LIN + PERFORM dspcol + * + ACCEPT success-flag AT 1401 UPDATE REQUIRED + + IF success AND COB-CRT-STATUS = 0 + GOBACK RETURNING 0 + ELSE + GOBACK RETURNING 1. + + dspcol. + DISPLAY scrblack LINE LIN COL 1, COLOR CBLACK. + DISPLAY scrblue LINE LIN COL 11, COLOR CBLUE. + DISPLAY scrgreen LINE LIN COL 21, COLOR CGREEN. + DISPLAY scrcyan LINE LIN COL 31, COLOR CCYAN. + DISPLAY scrred LINE LIN COL 41, COLOR CRED. + DISPLAY scrmaggy LINE LIN COL 51, COLOR CMAGENTA. + DISPLAY scryell LINE LIN COL 61, COLOR CYELLOW. + DISPLAY scrwhite LINE LIN COL 77, COLOR CWHITE. +]) + +AT_CHECK([$COMPILE prog.cob], [0], [], []) +MANUAL_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) + +AT_CLEANUP + + +AT_SETUP([field BACKGROUND- / FOREGROUND-COLOUR via CONTROL]) +AT_KEYWORDS([screen DISPLAY REVERSED HIGHLIGHT BLINK COLOR +BACKGROUND-COLOR BACKGROUND-COLOUR FOREGROUND-COLOR COLOUR]) + +AT_SKIP_IF([test "$COB_HAS_CURSES" != "yes"]) + +AT_DATA([prog.cob], [[ + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 success-flag PIC X VALUE 'Y'. + 88 success VALUE 'Y', 'y'. + + * ACU: "=", names only + 77 CBLACK PIC X(99) VALUE "FCOLOR=BLACK, " + & "BCOLOR=WHITE,". + 77 CBLUE PIC X(99) VALUE "FCOLOR=BLUE , " + & "BCOLOR=BLACK,". + * MF: "IS" or "=" or " ", also extended color numbers + 77 CGREEN PIC X(99) VALUE "FCOLOR IS GREEN, " + & "BCOLOR BLACK,". + 77 CCYAN PIC X(99) VALUE "FCOLOR =CYAN, " + & "BCOLOR= BLACK, ". + 77 CRED PIC X(99) VALUE "FCOLOR=RED " + & "BCOLOR=BLACK, ". + 77 CMAGENTA PIC X(99) VALUE "FCOLOR=MAGENTA, " + & "BCOLOR=BLACK,". + 77 CYELLOW PIC X(99) VALUE "FCOLOR = 6, " + & "BCOLOR=BLACK,". + 77 CWHITE PIC X(99) VALUE "FCOLOR=WHITE, " + & "BCOLOR=BLACK, ". + + 77 LIN PIC 99 COMP-5. + + 01 scr1 PIC X(75) + VALUE 'Enter "y" if the text below matches the colour ' + & 'of the background/text.'. + 01 scr2 PIC X(75) + VALUE 'Note: the black text is on white background/the ' + & 'white background has black'. + 01 scr3 PIC X(75) + VALUE 'text to make the text visible.' + & ' [This text *may* has "surrounding lines".]'. + 01 scr8 PIC X(75) + VALUE 'following lines should be identical but ' + & 'highlighted for the first line'. + 01 scr9 PIC X(75) + VALUE 'and blinking for the second one.'. + + 01 scrblack PIC X(08) VALUE 'Black'. + 01 scrblue PIC X(08) VALUE 'Blue'. + 01 scrgreen PIC X(08) VALUE 'Green'. + 01 scrcyan PIC X(08) VALUE 'Cyan'. + 01 scrred PIC X(08) VALUE 'Red'. + 01 scrmaggy PIC X(08) VALUE 'Magenta'. + 01 scryell PIC X(14) VALUE 'Brown/Yellow'. + 01 scrwhite PIC X(08) VALUE 'White'. + + PROCEDURE DIVISION. + testme. + MOVE 2 TO LIN + DISPLAY scr1 ( 1:1) AT LINE LIN COL 2 + CONTROL "LEFTLINE OVERLINE" + DISPLAY scr1 ( 2:) AT LINE LIN COL 2 + 1 + CONTROL "OVERLINE" + DISPLAY scr1 (75:) AT LINE LIN COL 2 + 75 + CONTROL "OVERLINE RIGHTLINE" + ADD 1 TO LIN + DISPLAY scr2 ( 1:1) AT LINE LIN COL 2 + CONTROL "LEFTLINE" + DISPLAY scr2 ( 2:) AT LINE LIN COL 2 + 1 + DISPLAY scr2 (75:) AT LINE LIN COL 2 + 75 + CONTROL "RIGHTLINE" + ADD 1 TO LIN + DISPLAY scr3 ( 1:1) AT LINE LIN COL 2 + CONTROL "LEFTLINE UNDERLINE" + DISPLAY scr3 ( 2:) AT LINE LIN COL 2 + 1 + CONTROL "UNDERLINE" + DISPLAY scr3 (75:) AT LINE LIN COL 2 + 75 + CONTROL "UNDERLINE RIGHTLINE" + * + ADD 2 TO LIN + PERFORM dspcol + MOVE "REVERSE," TO + CBLACK (40:), CBLUE (40:), CGREEN (40:), CCYAN (40:), + CRED (40:), CMAGENTA (40:), CYELLOW (40:), CWHITE (40:) + ADD 1 TO LIN + PERFORM dspcol + * + INSPECT CRED REPLACING ALL "=" BY " " + ADD 2 TO LIN + DISPLAY scr8 AT LINE LIN COL 2 + ADD 1 TO LIN + DISPLAY scr9 AT LINE LIN COL 2 + * + MOVE "HIGHLIGHT,NO REVERSE" TO + CBLACK (50:), CBLUE (50:), CGREEN (50:), CCYAN (50:), + CRED (50:), CMAGENTA (50:), CYELLOW (50:), CWHITE (50:) + ADD 1 TO LIN + PERFORM dspcol + MOVE "NO HIGH, BLINK" TO + CBLACK (60:), CBLUE (60:), CGREEN (60:), CCYAN (60:), + CRED (60:), CMAGENTA (60:), CYELLOW (60:), CWHITE (60:) + MOVE 12 TO LIN + PERFORM dspcol + * + ACCEPT success-flag AT 1801 UPDATE REQUIRED + + IF success AND COB-CRT-STATUS = 0 + GOBACK RETURNING 0 + ELSE + GOBACK RETURNING 1. + + dspcol. + DISPLAY scrblack LINE LIN COL 1, CONTROL CBLACK. + DISPLAY scrblue LINE LIN COL 10, CONTROL CBLUE. + DISPLAY scrgreen LINE LIN COL 19, CONTROL CGREEN. + DISPLAY scrcyan LINE LIN COL 28, CONTROL CCYAN. + DISPLAY scrred LINE LIN COL 37, CONTROL CRED. + DISPLAY scrmaggy LINE LIN COL 46, CONTROL CMAGENTA. + DISPLAY scryell LINE LIN COL 55, CONTROL CYELLOW. + DISPLAY scrwhite LINE LIN COL 70, CONTROL CWHITE. +]]) + +AT_CHECK([$COMPILE prog.cob], [0], [], []) +MANUAL_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) + +AT_CLEANUP + + +AT_SETUP([line draw characters via CONTROL GRAPHICS]) +AT_KEYWORDS([screen DISPLAY]) + +AT_SKIP_IF([test "$COB_HAS_CURSES" != "yes"]) + +AT_DATA([prog.cob], [[ + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 success-flag PIC X VALUE 'Y'. + 88 success VALUE 'Y', 'y'. + + 77 LIN-START PIC 99 COMP-5. + 77 LIN PIC 99 COMP-5. + + 01 scr1 PIC X(75) + VALUE 'Enter "y" if you see line draw characters. ' + & 'The first set (single/double)'. + 01 scr2 PIC X(75) + VALUE 'uses HIGHLIGHT, the second uses ' + & 'LOWLIGHT, BLINK and MAGENTA.'. + + 01 graphcontrol PIC X(50) VALUE 'HIGH, GRAPHICS'. + + PROCEDURE DIVISION. + testme. + MOVE 2 TO LIN + DISPLAY scr1 AT LINE LIN COL 2 + ADD 1 TO LIN + DISPLAY scr2 AT LINE LIN COL 2 + * + MOVE 5 TO LIN-START + PERFORM dspcol + MOVE 12 TO LIN-START + MOVE "LOW BLINK FCOLOR=MAGENTA GRAPHICS" TO graphcontrol + PERFORM dspcol + * + ACCEPT success-flag AT 1801 UPDATE REQUIRED + + IF success AND COB-CRT-STATUS = 0 + GOBACK RETURNING 0 + ELSE + GOBACK RETURNING 1. + + dspcol. + * Single-line graphics + MOVE LIN-START TO LIN + DISPLAY "lqqqqwqqqqk" LINE LIN COL 05, CONTROL graphcontrol. + ADD 1 TO LIN + DISPLAY "x x x" LINE LIN COL 05, CONTROL graphcontrol. + ADD 1 TO LIN + DISPLAY "tqqqqnqqqqu" LINE LIN COL 05, CONTROL graphcontrol. + ADD 1 TO LIN + DISPLAY "x x x" LINE LIN COL 05, CONTROL graphcontrol. + ADD 1 TO LIN + DISPLAY "mqqqqvqqqqj" LINE LIN COL 05, CONTROL graphcontrol. + ADD 1 TO LIN + * Double-line graphics + MOVE LIN-START TO LIN + DISPLAY "LQQQQWQQQQK" LINE LIN COL 20, CONTROL graphcontrol. + ADD 1 TO LIN + DISPLAY "X X X" LINE LIN COL 20, CONTROL graphcontrol. + ADD 1 TO LIN + DISPLAY "TQQQQNQQQQU" LINE LIN COL 20, CONTROL graphcontrol. + ADD 1 TO LIN + DISPLAY "X X X" LINE LIN COL 20, CONTROL graphcontrol. + ADD 1 TO LIN + DISPLAY "MQQQQVQQQQJ" LINE LIN COL 20, CONTROL graphcontrol. +]]) + +AT_CHECK([$COMPILE prog.cob], [0], [], []) +MANUAL_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) + +AT_CLEANUP + + +AT_SETUP([BEEP]) +AT_KEYWORDS([BELL FLASH]) + +AT_SKIP_IF([test "$COB_HAS_CURSES" != "yes"]) + +AT_DATA([prog.cob], [ + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 success-flag PIC X. + 88 success VALUE 'Y', 'y'. + + SCREEN SECTION. + 01 scr. + 03 BELL. + 03 VALUE 'Enter "y" if you heard a beep:'. + 03 success-field PIC X, COL + 2, REQUIRED, TO success-flag + FROM 'Y'. + 01 scr2. + 03 LINE 4 VALUE 'system beep may be turned off ' & + 'on this system.'. + 03 LINE 5 VALUE 'Retesting with COB_BELL=FLASH...'. + 03 LINE + 2, + VALUE 'Enter "y" if you''ve seen your terminal flash'. + 03 success-field PIC X, COL + 2, REQUIRED, TO success-flag + FROM 'Y'. + + PROCEDURE DIVISION. + DISPLAY scr + ACCEPT scr + + IF success AND COB-CRT-STATUS = 0 + GOBACK RETURNING 0 + END-IF + + SET ENVIRONMENT 'COB_BELL' TO 'FLASH' + CALL 'C$SLEEP' USING '1' + + DISPLAY scr2 + DISPLAY ALL X'07' UPON CRT + ACCEPT scr2 + + IF success AND COB-CRT-STATUS = 0 + GOBACK RETURNING 0 + ELSE + GOBACK RETURNING 1 + END-IF + . +]) + +AT_CHECK([$COMPILE prog.cob], [0], [], []) +MANUAL_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) + +AT_CLEANUP + + +AT_SETUP([BLANK LINE]) +AT_KEYWORDS([screen]) + +AT_SKIP_IF([test "$COB_HAS_CURSES" != "yes"]) + +AT_DATA([prog.cob], [ + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 success-flag PIC X VALUE 'Y'. + 88 success VALUE 'Y', 'y'. + + SCREEN SECTION. + 01 scr-1. + 03 LINE 3 VALUE 'Lorem ipsum dolor sit amet, consectetur ad' + & 'ipiscing elit. Curabitur dapibus dui'. + 03 LINE 4 VALUE 'vitae augue lobortis, non tempor diam tris' + & 'tique. Donec dignissim ex velit, ut'. + 03 LINE 5 VALUE 'efficitur tellus pharetra at. Curabitur at' + & ' condimentum nunc, nec accumsan'. + 03 LINE 6 VALUE 'nulla. Nulla at feugiat elit, eget condime' + & 'ntum justo. Nam lorem lectus,'. + 03 LINE 7 VALUE 'imperdiet sit amet odio eu, eleifend conse' + & 'ctetur ligula. Duis diam felis, porta'. + 03 LINE 8 VALUE 'id diam id, ultrices finibus augue. Mauris' + & ' imperdiet, dolor sed sodales porta,'. + 03 LINE 9 VALUE 'justo nunc consequat nulla, iaculis venena' + & 'tis lorem libero sit amet'. + 03 LINE 10 VALUE 'magna. Nullam pulvinar nullam.'. + 03 success-field LINE + 2, PIC X, REQUIRED, + USING success-flag. + + 01 scr-2. + 03 LINE 6 COL 8 VALUE 'foo' BLANK LINE, HIGHLIGHT. + 03 LINE 1 VALUE 'Enter "y" if foo is the only word on one' + & ' line.'. + + PROCEDURE DIVISION. + DISPLAY scr-1 + DISPLAY scr-2 + ACCEPT success-field + + IF success AND COB-CRT-STATUS = 0 + GOBACK RETURNING 0 + ELSE + GOBACK RETURNING 1 + END-IF + . +]) + +AT_CHECK([$COMPILE prog.cob], [0], [], []) +MANUAL_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) + +AT_CLEANUP + + +AT_SETUP([BLANK SCREEN]) +AT_KEYWORDS([screen]) + +AT_SKIP_IF([test "$COB_HAS_CURSES" != "yes"]) + +AT_DATA([prog.cob], [ + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 success-flag PIC X VALUE 'Y'. + 88 success VALUE 'Y', 'y'. + + SCREEN SECTION. + 01 scr-1. + 03 LINE 3 VALUE 'Lorem ipsum dolor sit amet, consectetur ad' + & 'ipiscing elit. Curabitur dapibus dui'. + 03 LINE 4 VALUE 'vitae augue lobortis, non tempor diam tris' + & 'tique. Donec dignissim ex velit, ut'. + 03 LINE 5 VALUE 'efficitur tellus pharetra at. Curabitur at' + & ' condimentum nunc, nec accumsan'. + 03 LINE 6 VALUE 'nulla. Nulla at feugiat elit, eget condime' + & 'ntum justo. Nam lorem lectus,'. + 03 LINE 7 VALUE 'imperdiet sit amet odio eu, eleifend conse' + & 'ctetur ligula. Duis diam felis, porta'. + 03 LINE 8 VALUE 'id diam id, ultrices finibus augue. Mauris' + & ' imperdiet, dolor sed sodales porta,'. + 03 LINE 9 VALUE 'justo nunc consequat nulla, iaculis venena' + & 'tis lorem libero sit amet'. + 03 LINE 10 VALUE 'magna. Nullam pulvinar nullam.'. + 03 success-field LINE + 2, PIC X, REQUIRED, + USING success-flag. + + 01 scr-2. + 03 LINE 6 COL 8 VALUE 'foo' BLANK SCREEN, HIGHLIGHT. + 03 LINE 1 VALUE 'Enter "y" if foo is the only word below.'. + + PROCEDURE DIVISION. + DISPLAY scr-1 + DISPLAY scr-2 + ACCEPT success-field + + IF success AND COB-CRT-STATUS = 0 + GOBACK RETURNING 0 + ELSE + GOBACK RETURNING 1 + END-IF + . +]) + +AT_CHECK([$COMPILE prog.cob], [0], [], []) +MANUAL_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) + +AT_CLEANUP + + +AT_SETUP([BLANK ignored in ACCEPT]) +AT_KEYWORDS([screen]) + +AT_SKIP_IF([test "$COB_HAS_CURSES" != "yes"]) + +AT_DATA([prog.cob], [ + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 success-flag PIC X VALUE 'Y'. + 88 success VALUE 'Y', 'y'. + + SCREEN SECTION. + 01 scr. + 03 LINE 1 VALUE 'Enter "y" if you can see lorem ipsum ' + & 'filler text.'. + 03 LINE 3 COL 3 VALUE 'Lorem ipsum dolor sit amet,' + & ' consectetur ad ipiscing elit.'. + + 01 success-scr. + 03 LINE 3, BLANK LINE, PIC X, REQUIRED, USING success-flag. + + PROCEDURE DIVISION. + DISPLAY scr + ACCEPT success-scr + + IF success AND COB-CRT-STATUS = 0 + GOBACK RETURNING 0 + ELSE + GOBACK RETURNING 1 + END-IF + . +]) + +AT_CHECK([$COMPILE prog.cob], [0], [], []) +MANUAL_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) + +AT_CLEANUP + + +AT_SETUP([BLINK]) +AT_KEYWORDS([screen]) + +AT_SKIP_IF([test "$COB_HAS_CURSES" != "yes"]) + +AT_DATA([prog.cob], [ + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 success-flag PIC X VALUE 'Y'. + 88 success VALUE 'Y', 'y'. + + SCREEN SECTION. + 01 scr. + 03 PIC X(80) + VALUE 'Enter "y" if the string below is blinking:'. + 03 LINE + 1, PIC X(10) VALUE 'Blink' BLINK. + 03 success-field LINE + 2, PIC X, REQUIRED, + USING success-flag. + + PROCEDURE DIVISION. + DISPLAY scr + ACCEPT scr + + IF success AND COB-CRT-STATUS = 0 + GOBACK RETURNING 0 + ELSE + GOBACK RETURNING 1 + END-IF + . +]) + +AT_CHECK([$COMPILE prog.cob], [0], [], []) +MANUAL_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) + +AT_CLEANUP + + +AT_SETUP([ERASE EOS]) +AT_KEYWORDS([screen]) + +AT_SKIP_IF([test "$COB_HAS_CURSES" != "yes"]) + +AT_DATA([prog.cob], [ + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 success-flag PIC X VALUE 'Y'. + 88 success VALUE 'Y', 'y'. + + SCREEN SECTION. + 01 scr-1. + 03 LINE 1 VALUE 'Enter "y" if all the text after foo in the' + & ' screen has been erased.'. + 03 LINE 3 VALUE 'Lorem ipsum dolor sit amet, consectetur ad' + & 'ipiscing elit. Curabitur dapibus dui'. + 03 LINE 4 VALUE 'vitae augue lobortis, non tempor diam tris' + & 'tique. Donec dignissim ex velit, ut'. + 03 LINE 5 VALUE 'efficitur tellus pharetra at. Curabitur at' + & ' condimentum nunc, nec accumsan'. + 03 LINE 6 VALUE 'nulla. Nulla at feugiat elit, eget condime' + & 'ntum justo. Nam lorem lectus,'. + 03 LINE 7 VALUE 'imperdiet sit amet odio eu, eleifend conse' + & 'ctetur ligula. Duis diam felis, porta'. + 03 LINE 8 VALUE 'id diam id, ultrices finibus augue. Mauris' + & ' imperdiet, dolor sed sodales porta,'. + 03 LINE 9 VALUE 'justo nunc consequat nulla, iaculis venena' + & 'tis lorem libero sit amet'. + 03 LINE 10 VALUE 'magna. Nullam pulvinar nullam.'. + 03 success-field LINE + 2, PIC X, REQUIRED, + USING success-flag. + + 01 scr-2. + 03 LINE 6 COL 8 VALUE 'foo' ERASE EOS, HIGHLIGHT. + + PROCEDURE DIVISION. + DISPLAY scr-1 + DISPLAY scr-2 + ACCEPT success-field + + IF success AND COB-CRT-STATUS = 0 + GOBACK RETURNING 0 + ELSE + GOBACK RETURNING 1 + END-IF + . +]) + +AT_CHECK([$COMPILE prog.cob], [0], [], []) +MANUAL_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) + +AT_CLEANUP + + +AT_SETUP([ERASE EOL]) +AT_KEYWORDS([screen]) + +AT_SKIP_IF([test "$COB_HAS_CURSES" != "yes"]) + +AT_DATA([prog.cob], [ + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 success-flag PIC X VALUE 'Y'. + 88 success VALUE 'Y', 'y'. + + SCREEN SECTION. + 01 scr-1. + 03 LINE 1 VALUE 'Enter "y" if all the text after foo on ' + & 'that line alone has been erased.'. + 03 LINE 3 VALUE 'Lorem ipsum dolor sit amet, consectetur ad' + & 'ipiscing elit. Curabitur dapibus dui'. + 03 LINE 4 VALUE 'vitae augue lobortis, non tempor diam tris' + & 'tique. Donec dignissim ex velit, ut'. + 03 LINE 5 VALUE 'efficitur tellus pharetra at. Curabitur at' + & ' condimentum nunc, nec accumsan'. + 03 LINE 6 VALUE 'nulla. Nulla at feugiat elit, eget condime' + & 'ntum justo. Nam lorem lectus,'. + 03 LINE 7 VALUE 'imperdiet sit amet odio eu, eleifend conse' + & 'ctetur ligula. Duis diam felis, porta'. + 03 LINE 8 VALUE 'id diam id, ultrices finibus augue. Mauris' + & ' imperdiet, dolor sed sodales porta,'. + 03 LINE 9 VALUE 'justo nunc consequat nulla, iaculis venena' + & 'tis lorem libero sit amet'. + 03 LINE 10 VALUE 'magna. Nullam pulvinar nullam.'. + 03 success-field LINE + 2, PIC X, REQUIRED, + USING success-flag. + + 01 scr-2. + 03 LINE 6 COL 8 VALUE 'foo' ERASE EOL, HIGHLIGHT. + + PROCEDURE DIVISION. + DISPLAY scr-1 + DISPLAY scr-2 + ACCEPT success-field + + IF success AND COB-CRT-STATUS = 0 + GOBACK RETURNING 0 + ELSE + GOBACK RETURNING 1 + END-IF + . +]) + +AT_CHECK([$COMPILE prog.cob], [0], [], []) +MANUAL_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) + +AT_CLEANUP + + +AT_SETUP([ERASE ignored in ACCEPT]) +AT_KEYWORDS([EOS]) + +AT_SKIP_IF([test "$COB_HAS_CURSES" != "yes"]) + +AT_DATA([prog.cob], [ + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 success-flag PIC X VALUE 'Y'. + 88 success VALUE 'Y', 'y'. + + SCREEN SECTION. + 01 scr. + 03 LINE 1 VALUE 'Enter "y" if you can see lorem ipsum ' + & 'filler text.'. + 03 LINE 3 VALUE 'Lorem ipsum dolor sit amet, consectetur ad' + & 'ipiscing elit. Curabitur dapibus dui'. + 03 LINE 4 VALUE 'vitae augue lobortis, non tempor diam tris' + & 'tique. Donec dignissim ex velit, ut'. + 03 LINE 5 VALUE 'efficitur tellus pharetra at. Curabitur at' + & ' condimentum nunc, nec accumsan'. + 03 LINE 6 VALUE 'nulla. Nulla at feugiat elit, eget condime' + & 'ntum justo. Nam lorem lectus,'. + 03 LINE 7 VALUE 'imperdiet sit amet odio eu, eleifend conse' + & 'ctetur ligula. Duis diam felis, porta'. + 03 LINE 8 VALUE 'id diam id, ultrices finibus augue. Mauris' + & ' imperdiet, dolor sed sodales porta,'. + 03 LINE 9 VALUE 'justo nunc consequat nulla, iaculis venena' + & 'tis lorem libero sit amet'. + 03 LINE 10 VALUE 'magna. Nullam pulvinar nullam.'. + 03 LINE 3 ERASE EOS. + 03 success-field LINE 12, PIC X, REQUIRED, + USING success-flag. + + PROCEDURE DIVISION. + DISPLAY scr + ACCEPT scr + + IF success AND COB-CRT-STATUS = 0 + GOBACK RETURNING 0 + ELSE + GOBACK RETURNING 1 + END-IF + . +]) + +AT_CHECK([$COMPILE prog.cob], [0], [], []) +MANUAL_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) + +AT_CLEANUP + + +AT_SETUP([FULL and REQUIRED]) +AT_KEYWORDS([screen]) + +AT_SKIP_IF([test "$COB_HAS_CURSES" != "yes"]) + +AT_DATA([prog.cob], [ + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 dummy PIC X(10). + 01 success-flag PIC X. + 88 success VALUE 'Y', 'y'. + + SCREEN SECTION. + 01 scr. + 03 PIC X(80) + VALUE 'Enter "y" if you cannot continue without filling ' + & 'all of the below field:'. + 03 LINE + 1, PIC X(10), FULL, REQUIRED, TO dummy. + *> no initial value for success as we request input + 03 success-field LINE + 2, PIC X, REQUIRED, TO success-flag. + + PROCEDURE DIVISION. + DISPLAY scr + ACCEPT scr + + IF success AND COB-CRT-STATUS = 0 + GOBACK RETURNING 0 + ELSE + GOBACK RETURNING 1 + END-IF + . +]) + +AT_CHECK([$COMPILE prog.cob], [0], [], []) +MANUAL_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) + +AT_CLEANUP + + +AT_SETUP([HIGHLIGHT]) +AT_KEYWORDS([screen]) + +AT_SKIP_IF([test "$COB_HAS_CURSES" != "yes"]) + +AT_DATA([prog.cob], [ + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 success-flag PIC X VALUE 'Y'. + 88 success VALUE 'Y', 'y'. + + SCREEN SECTION. + 01 scr. + 03 PIC X(80) + VALUE 'Enter "y" if the text below is bright ' + & '(highlighted):'. + 03 LINE + 1, PIC X(10) VALUE 'Highlight' HIGHLIGHT. + 03 success-field LINE + 2, PIC X, REQUIRED, + USING success-flag. + + PROCEDURE DIVISION. + DISPLAY scr + ACCEPT scr + + IF success AND COB-CRT-STATUS = 0 + GOBACK RETURNING 0 + ELSE + GOBACK RETURNING 1 + END-IF + . +]) + +AT_CHECK([$COMPILE prog.cob], [0], [], []) +MANUAL_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) + +AT_CLEANUP + + +AT_SETUP([INITIAL]) +AT_KEYWORDS([screen]) + +AT_SKIP_IF([test "$COB_HAS_CURSES" != "yes"]) + +AT_DATA([prog.cob], [ + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 dummy-1 PIC X(10). + 01 dummy-2 PIC X(10). + 01 dummy-3 PIC X(10). + + 01 success-flag PIC X VALUE 'Y'. + 88 success VALUE 'Y', 'y'. + + SCREEN SECTION. + 01 scr. + 03 PIC X(80) VALUE 'Enter "y" if the cursor is initially '- + 'located at the start of the rightmost'. + 03 LINE + 1, PIC X(80) VALUE 'field.'. + 03 LINE + 2, PIC X(10) TO dummy-1. + 03 COL + 2, PIC X(10) TO dummy-2. + 03 COL + 2, PIC X(10) TO dummy-3, INITIAL. + 03 success-field LINE + 2, PIC X, REQUIRED, + USING success-flag. + + PROCEDURE DIVISION. + DISPLAY scr + ACCEPT scr + + IF success AND COB-CRT-STATUS = 0 + GOBACK RETURNING 0 + ELSE + GOBACK RETURNING 1 + END-IF + . +]) + +AT_CHECK([$COMPILE prog.cob], [0], [], []) +MANUAL_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) + +AT_CLEANUP + + +AT_SETUP([LEFTLINE]) +AT_KEYWORDS([GRID]) + +AT_SKIP_IF([test "$COB_HAS_CURSES" != "yes"]) + +# Currently not implemented +AT_XFAIL_IF([true]) + +AT_DATA([prog.cob], [ + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 success-flag PIC X VALUE 'Y'. + 88 success VALUE 'Y', 'y'. + + SCREEN SECTION. + 01 scr. + 03 PIC X(80) + VALUE 'Enter "y" if the string has a vertical line to ' + & 'its left:'. + 03 LINE + 1, COL 2, PIC X(10) VALUE 'Leftline' LEFTLINE. + 03 success-field LINE + 2, PIC X, REQUIRED, + USING success-flag. + + PROCEDURE DIVISION. + DISPLAY scr + ACCEPT scr + + IF success AND COB-CRT-STATUS = 0 + GOBACK RETURNING 0 + ELSE + GOBACK RETURNING 1 + END-IF + . +]) + +AT_CHECK([$COMPILE prog.cob], [0], [], []) +MANUAL_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) + +AT_CLEANUP + + +AT_SETUP([LOWLIGHT]) +AT_KEYWORDS([screen]) + +AT_SKIP_IF([test "$COB_HAS_CURSES" != "yes"]) + +AT_DATA([prog.cob], [ + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 success-flag PIC X VALUE 'Y'. + 88 success VALUE 'Y', 'y'. + + SCREEN SECTION. + 01 scr. + 03 PIC X(80) + VALUE 'Enter "y" if the string below is dim (lowlight):'. + 03 LINE + 1, PIC X(10) VALUE 'Lowlight' LOWLIGHT. + 03 success-field LINE + 2, PIC X, REQUIRED, + USING success-flag. + + PROCEDURE DIVISION. + DISPLAY scr + ACCEPT scr + + IF success AND COB-CRT-STATUS = 0 + GOBACK RETURNING 0 + ELSE + GOBACK RETURNING 1 + END-IF + . +]) + +AT_CHECK([$COMPILE prog.cob], [0], [], []) +MANUAL_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) + +AT_CLEANUP + + +AT_SETUP([OVERLINE]) +AT_KEYWORDS([screen]) + +AT_SKIP_IF([test "$COB_HAS_CURSES" != "yes"]) + +# Currently not implemented +AT_XFAIL_IF([true]) + +AT_DATA([prog.cob], [ + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 success-flag PIC X VALUE 'Y'. + 88 success VALUE 'Y', 'y'. + + SCREEN SECTION. + 01 scr. + 03 PIC X(80) + VALUE 'Enter "y" if the string below is overlined:'. + 03 LINE + 1, PIC X(10) VALUE 'Overline' OVERLINE. + 03 success-field LINE + 2, PIC X, REQUIRED, + USING success-flag. + + PROCEDURE DIVISION. + DISPLAY scr + ACCEPT scr + + IF success AND COB-CRT-STATUS = 0 + GOBACK RETURNING 0 + ELSE + GOBACK RETURNING 1 + END-IF + . +]) + +AT_CHECK([$COMPILE prog.cob], [0], [], []) +MANUAL_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) + +AT_CLEANUP + + +AT_SETUP([REVERSE-VIDEO]) +AT_KEYWORDS([screen]) + +AT_SKIP_IF([test "$COB_HAS_CURSES" != "yes"]) + +AT_DATA([prog.cob], [ + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 success-flag PIC X VALUE 'Y'. + 88 success VALUE 'Y', 'y'. + + SCREEN SECTION. + 01 scr. + 03 PIC X(80) + VALUE 'Enter "y" if the background and foreground ' + & 'colours of the string below have'. + 03 LINE + 1, PIC X(80) VALUE 'swapped:'. + 03 LINE + 1, PIC X(20) VALUE 'Reversed colours' + REVERSE-VIDEO. + 03 success-field LINE + 2, PIC X USING success-flag. + + PROCEDURE DIVISION. + DISPLAY scr + ACCEPT scr + + IF success AND COB-CRT-STATUS = 0 + GOBACK RETURNING 0 + ELSE + GOBACK RETURNING 1 + END-IF + . +]) + +AT_CHECK([$COMPILE prog.cob], [0], [], []) +MANUAL_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) + +AT_CLEANUP + + +AT_SETUP([SECURE]) +AT_KEYWORDS([PASSWORD]) + +AT_SKIP_IF([test "$COB_HAS_CURSES" != "yes"]) + +AT_DATA([prog.cob], [ + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 dummy PIC X(10). + 01 success-flag PIC X VALUE 'Y'. + 88 success VALUE 'Y', 'y'. + + SCREEN SECTION. + 01 scr. + 03 PIC X(80) + VALUE 'Enter "y" if text in the field below is replaced ' + & 'with asterisks:'. + 03 LINE + 1, PIC X(10) SECURE TO dummy, PROMPT CHARACTER + "-". + 03 success-field LINE + 2, PIC X, REQUIRED, + USING success-flag. + + PROCEDURE DIVISION. + DISPLAY scr + ACCEPT scr + + IF success AND COB-CRT-STATUS = 0 + GOBACK RETURNING 0 + ELSE + GOBACK RETURNING 1 + END-IF + . +]) + +AT_CHECK([$COMPILE prog.cob], [0], [], []) +MANUAL_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) + +AT_CLEANUP + + +AT_SETUP([SIZE with items]) +AT_KEYWORDS([PROTECTED extensions]) + +AT_SKIP_IF([test "$COB_HAS_CURSES" != "yes"]) + +AT_DATA([prog.cob], [ + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 success-flag PIC X VALUE 'Y'. + 88 success VALUE 'Y', 'y'. + + 01 num-1 PIC 9(5) VALUE 12345. + 01 num-2 PIC X(10) VALUE '12345'. + 01 num-3 PIC 9(4) VALUE 1234. + + 01 four PIC 9 VALUE 4. + + PROCEDURE DIVISION. + DISPLAY 'Enter "y" if you see exactly four rows of 1234, all' + & ' aligned.' LINE 1 + + DISPLAY num-1 LINE 3 COL 3, SIZE 4; + num-2 LINE 4 COL 3, SIZE four; + num-3 LINE 5 COL 3, SIZE 8; + '1234' LINE 6 COL 3, SIZE ZERO + + ACCEPT success-flag LINE 8, REQUIRED UPDATE + + IF success AND COB-CRT-STATUS = 0 + GOBACK RETURNING 0 + ELSE + GOBACK RETURNING 1 + END-IF + . +]) + +AT_CHECK([$COMPILE prog.cob], [0], [], []) +MANUAL_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) + +AT_CLEANUP + + +AT_SETUP([SIZE with figurative constants]) +AT_KEYWORDS([PROTECTED extensions]) + +AT_SKIP_IF([test "$COB_HAS_CURSES" != "yes"]) + +AT_DATA([prog.cob], [ + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 success-flag PIC X VALUE 'Y'. + 88 success VALUE 'Y', 'y'. + + PROCEDURE DIVISION. + DISPLAY 'Enter "y" if you see exactly three rows of quotes, ' + & 'zeroes and ''abc'',', LINE 1 + DISPLAY '8 characters long, all aligned.', LINE 2 + + DISPLAY QUOTES LINE 4 COL 3, SIZE 8; + ZEROES LINE 5 COL 3, SIZE 8; + ALL 'abc' LINE 6 COL 3, SIZE 8 + + DISPLAY '123456789' LINE 7 COL 3 + DISPLAY SPACE LINE 7 COL 3, SIZE 9 + + ACCEPT success-flag LINE 8, REQUIRED UPDATE + + IF success AND COB-CRT-STATUS = 0 + GOBACK RETURNING 0 + ELSE + GOBACK RETURNING 1 + END-IF + . +]) + +AT_CHECK([$COMPILE prog.cob], [0], [], []) +MANUAL_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) + +AT_CLEANUP + + +AT_SETUP([UPDATE]) +AT_KEYWORDS([extensions]) + +AT_SKIP_IF([test "$COB_HAS_CURSES" != "yes"]) + +AT_DATA([prog.cob], [ + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 n-str PIC X(12) VALUE SPACES. + 01 success-flag PIC X. + 88 success VALUE 'Y', 'y'. + + SCREEN SECTION. + 01 scr. + 03 VALUE 'Enter "y" if the entry field below is filled with' + & ' N''s'. + 03 n-field, LINE + 1, PIC X(12) USING n-str. + 03 success-field, LINE + 2, PIC X, REQUIRED, + TO success-flag, FROM 'Y'. + + PROCEDURE DIVISION. + DISPLAY scr + MOVE ALL 'N' TO n-str + ACCEPT scr + + IF success AND COB-CRT-STATUS = 0 + GOBACK RETURNING 0 + ELSE + GOBACK RETURNING 1 + END-IF + . +]) + +AT_CHECK([$COMPILE -fno-accept-update prog.cob], [0], [], []) +MANUAL_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) + +AT_CLEANUP + + +AT_SETUP([UNDERLINE]) +AT_KEYWORDS([screen]) + +AT_SKIP_IF([test "$COB_HAS_CURSES" != "yes"]) + +AT_DATA([prog.cob], [ + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 success-flag PIC X VALUE 'Y'. + 88 success VALUE 'Y', 'y'. + + SCREEN SECTION. + 01 scr. + 03 PIC X(80) + VALUE 'Enter "y" if the string below is underlined:'. + 03 LINE + 1, PIC X(10) VALUE 'Underline' UNDERLINE. + 03 success-field LINE + 2, PIC X, REQUIRED, + USING success-flag. + + PROCEDURE DIVISION. + DISPLAY scr + ACCEPT scr + + IF success AND COB-CRT-STATUS = 0 + GOBACK RETURNING 0 + ELSE + GOBACK RETURNING 1 + END-IF + . +]) + +AT_CHECK([$COMPILE prog.cob], [0], [], []) +MANUAL_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) + +AT_CLEANUP + + +AT_SETUP([SPECIAL-NAMES CURSOR phrase 6-digit with field]) +AT_KEYWORDS([position ACCEPT]) + +AT_SKIP_IF([test "$COB_HAS_CURSES" != "yes"]) + +AT_DATA([prog.cob], [ + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + ENVIRONMENT DIVISION. + CONFIGURATION SECTION. + SPECIAL-NAMES. + CURSOR IS cur-pos. + DATA DIVISION. + WORKING-STORAGE SECTION. + 77 cur-pos pic 9(06). + 01 success-flag PIC X VALUE 'Y'. + 88 success VALUE 'Y', 'y'. + 01 ws-x-20 PIC X(20). + PROCEDURE DIVISION. + testme. + set environment 'COB_SCREEN_EXCEPTIONS' to 'TRUE' + set environment 'COB_SCREEN_ESC' to 'TRUE' + + DISPLAY "If the cursor below is positioned at the 'C'" + LINE 1 COLUMN 1. + DISPLAY "(third column) below, then position it at the" + LINE 2 COLUMN 1. + DISPLAY "'E' (fifth column) and press ENTER." + LINE 3 COLUMN 1. + + MOVE "ABCDEFG " TO WS-X-20. + MOVE 005003 TO cur-pos. + ACCEPT WS-X-20 + LINE 5 COLUMN 1 + WITH + AUTO-SKIP + SIZE 10 + UPDATE. + + IF cur-pos = 005005 AND COB-CRT-STATUS = 0 + GOBACK RETURNING 0 + ELSE + GOBACK RETURNING 1 + END-IF + . +]) + +AT_CHECK([$COMPILE prog.cob], [0], [], []) +MANUAL_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) + +AT_CLEANUP + + +AT_SETUP([SPECIAL-NAMES CURSOR phrase 4-digit with field]) +AT_KEYWORDS([position ACCEPT]) + +AT_SKIP_IF([test "$COB_HAS_CURSES" != "yes"]) + +AT_DATA([prog.cob], [ + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + ENVIRONMENT DIVISION. + CONFIGURATION SECTION. + SPECIAL-NAMES. + CURSOR IS cur-pos. + DATA DIVISION. + WORKING-STORAGE SECTION. + 77 cur-pos pic 9(04). + 01 success-flag PIC X VALUE 'Y'. + 88 success VALUE 'Y', 'y'. + 01 ws-x-20 PIC X(20). + PROCEDURE DIVISION. + testme. + set environment 'COB_SCREEN_EXCEPTIONS' to 'TRUE' + set environment 'COB_SCREEN_ESC' to 'TRUE' + + DISPLAY "If the cursor below is positioned at the 'C'" + LINE 1 COLUMN 1. + DISPLAY "(third column) below, then position it at the" + LINE 2 COLUMN 1. + DISPLAY "'E' (fifth column) and press ENTER." + LINE 3 COLUMN 1. + + MOVE "ABCDEFG " TO WS-X-20. + MOVE 0503 TO cur-pos. + ACCEPT WS-X-20 + LINE 5 COLUMN 1 + WITH + AUTO-SKIP + SIZE 10 + UPDATE. + + IF cur-pos = 0505 AND COB-CRT-STATUS = 0 + GOBACK RETURNING 0 + ELSE + GOBACK RETURNING 1 + END-IF + . +]) + +AT_CHECK([$COMPILE prog.cob], [0], [], []) +MANUAL_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) + +AT_CLEANUP + + +AT_SETUP([ACCEPT field WITH CURSOR data-item]) +AT_KEYWORDS([position]) + +AT_SKIP_IF([test "$COB_HAS_CURSES" != "yes"]) + +AT_DATA([prog.cob], [ + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 77 cur-pos pic 9(04). + 01 success-flag PIC X VALUE 'Y'. + 88 success VALUE 'Y', 'y'. + 01 ws-x-20 PIC X(20). + PROCEDURE DIVISION. + testme. + set environment 'COB_SCREEN_EXCEPTIONS' to 'TRUE' + set environment 'COB_SCREEN_ESC' to 'TRUE' + + DISPLAY "If the cursor below is positioned at the 'C'" + LINE 1 COLUMN 1. + DISPLAY "(third column in field) below, then position it at" + LINE 2 COLUMN 1. + DISPLAY "the 'E' (fifth column) and press ENTER." + LINE 3 COLUMN 1. + + MOVE "ABCDEFG " TO WS-X-20. + MOVE 0003 TO cur-pos. + ACCEPT WS-X-20 + LINE 5 COLUMN 3 + WITH + AUTO-SKIP + SIZE 10 + CURSOR cur-pos + UPDATE. + + IF cur-pos = 0005 AND COB-CRT-STATUS = 0 + GOBACK RETURNING 0 + ELSE + GOBACK RETURNING 1 + END-IF + . +]) + +AT_CHECK([$COMPILE prog.cob], [0], [], []) +MANUAL_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) + +AT_CLEANUP + + +AT_SETUP([ACCEPT field WITH CURSOR size overflow]) +AT_KEYWORDS([position]) + +AT_SKIP_IF([test "$COB_HAS_CURSES" != "yes"]) + +AT_DATA([prog.cob], [ + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 77 cur-pos pic 9(04). + 01 success-flag PIC X VALUE 'Y'. + 88 success VALUE 'Y', 'y'. + 01 ws-x-20 PIC X(10). + PROCEDURE DIVISION. + testme. + set environment 'COB_SCREEN_EXCEPTIONS' to 'TRUE' + set environment 'COB_SCREEN_ESC' to 'TRUE' + + DISPLAY "If the cursor below is positioned at the last" + LINE 1 COLUMN 1. + DISPLAY "column in the field below, then position it at" + LINE 2 COLUMN 1. + DISPLAY "the 'C' (third column) and press ENTER." + LINE 3 COLUMN 1. + + MOVE "ABCDEFGHIJ" TO WS-X-20. + MOVE 0012 TO cur-pos. + ACCEPT WS-X-20 + LINE 5 COLUMN 3 + WITH + AUTO-SKIP + SIZE 10 + CURSOR cur-pos + UPDATE. + + IF cur-pos = 0003 AND COB-CRT-STATUS = 0 + GOBACK RETURNING 0 + ELSE + GOBACK RETURNING 1 + END-IF + . +]) + +AT_CHECK([$COMPILE prog.cob], [0], [], []) +MANUAL_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) + +AT_CLEANUP + + +AT_SETUP([ACCEPT field WITH CURSOR data overflow I]) +AT_KEYWORDS([position]) + +AT_SKIP_IF([test "$COB_HAS_CURSES" != "yes"]) + +AT_DATA([prog.cob], [ + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 77 cur-pos pic 9(04). + 01 success-flag PIC X VALUE 'Y'. + 88 success VALUE 'Y', 'y'. + 01 ws-x-20 PIC X(20). + PROCEDURE DIVISION. + testme. + set environment 'COB_SCREEN_EXCEPTIONS' to 'TRUE' + set environment 'COB_SCREEN_ESC' to 'TRUE' + + DISPLAY "If the cursor below is positioned at the 'E'" + LINE 1 COLUMN 1. + DISPLAY "(fifth column in field) below, then position it at" + LINE 2 COLUMN 1. + DISPLAY "the 'C' (third column) and press ENTER." + LINE 3 COLUMN 1. + + MOVE "ABCDE " TO WS-X-20. + MOVE 0008 TO cur-pos. + ACCEPT WS-X-20 + LINE 5 COLUMN 3 + WITH + AUTO-SKIP + SIZE 10 + CURSOR cur-pos + UPDATE. + + IF cur-pos = 0003 AND COB-CRT-STATUS = 0 + GOBACK RETURNING 0 + ELSE + GOBACK RETURNING 1 + END-IF + . +]) + +AT_CHECK([$COMPILE prog.cob], [0], [], []) +MANUAL_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) + +AT_CLEANUP + + +AT_SETUP([ACCEPT field WITH CURSOR data overflow II]) +AT_KEYWORDS([position UNDERLINE]) + +AT_SKIP_IF([test "$COB_HAS_CURSES" != "yes"]) + +AT_DATA([prog.cob], [ + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 77 cur-pos pic 9(04). + 01 success-flag PIC X VALUE 'Y'. + 88 success VALUE 'Y', 'y'. + 01 ws-x-20 PIC X(20). + PROCEDURE DIVISION. + testme. + set environment 'COB_SCREEN_EXCEPTIONS' to 'TRUE' + set environment 'COB_SCREEN_ESC' to 'TRUE' + + DISPLAY "If the cursor below is positioned at the first" + LINE 1 COLUMN 1. + DISPLAY "column in the field below and it is empty, then" + LINE 2 COLUMN 1. + DISPLAY "enter 'AB', position after the 'B' and press ENTER." + LINE 3 COLUMN 1. + + MOVE "ABCDE " TO WS-X-20. + MOVE 0008 TO cur-pos. + ACCEPT WS-X-20 + LINE 5 COLUMN 3 + WITH + SIZE 10 + UNDERLINE + CURSOR cur-pos. + + IF cur-pos = 0003 AND COB-CRT-STATUS = 0 + GOBACK RETURNING 0 + ELSE + GOBACK RETURNING 1 + END-IF + . +]) + +AT_CHECK([$COMPILE prog.cob], [0], [], []) +MANUAL_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) + +AT_CLEANUP + + +AT_SETUP([ACCEPT field WITH CURSOR literal]) +AT_KEYWORDS([position]) + +AT_SKIP_IF([test "$COB_HAS_CURSES" != "yes"]) + +AT_DATA([prog.cob], [ + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 success-flag PIC X VALUE 'Y'. + 88 success VALUE 'Y', 'y'. + 01 ws-x-20 PIC X(20). + PROCEDURE DIVISION. + testme. + set environment 'COB_SCREEN_EXCEPTIONS' to 'TRUE' + set environment 'COB_SCREEN_ESC' to 'TRUE' + + DISPLAY "If the cursor below is positioned at the 'C'" + LINE 1 COLUMN 1. + DISPLAY "(third column in field) below, then press ENTER." + LINE 2 COLUMN 1. + + MOVE "ABCDEFG " TO WS-X-20. + ACCEPT WS-X-20 + LINE 4 COLUMN 2 + WITH + AUTO-SKIP + SIZE 10 + CURSOR 3 + UPDATE. + + IF COB-CRT-STATUS = 0 + GOBACK RETURNING 0 + ELSE + GOBACK RETURNING 1 + END-IF + . +]) + +AT_CHECK([$COMPILE prog.cob], [0], [], []) +MANUAL_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) + +AT_CLEANUP + + +AT_SETUP([HOME key]) +AT_KEYWORDS([HOME SIZE]) + +AT_SKIP_IF([test "$COB_HAS_CURSES" != "yes"]) + +AT_DATA([prog.cob], [ + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 success-flag PIC X VALUE 'Y'. + 88 success VALUE 'Y', 'y'. + 01 ws-x-20 PIC X(20). + PROCEDURE DIVISION. + DISPLAY "Enter 'y' if multiple presses of the HOME key" + LINE 1 COLUMN 1. + DISPLAY "go to the beginning of the field and the beginning" + LINE 2 COLUMN 1. + DISPLAY "of the characters." + LINE 3 COLUMN 1. + + MOVE " ABC " TO WS-X-20. + ACCEPT WS-X-20 + LINE 5 COLUMN 1 + WITH + AUTO-SKIP + SIZE 10 + UPDATE. + + ACCEPT SUCCESS-FLAG + LINE 7 COLUMN 1 + WITH UPDATE. + + IF success AND COB-CRT-STATUS = 0 + GOBACK RETURNING 0 + ELSE + GOBACK RETURNING 1 + END-IF + . +]) + +AT_CHECK([$COMPILE prog.cob], [0], [], []) +MANUAL_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) + +AT_CLEANUP + + +AT_SETUP([END key]) +AT_KEYWORDS([END SIZE position]) + +AT_SKIP_IF([test "$COB_HAS_CURSES" != "yes"]) + +AT_DATA([prog.cob], [ + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 success-flag PIC X VALUE 'Y'. + 88 success VALUE 'Y', 'y'. + 01 ws-x-20 PIC X(20). + PROCEDURE DIVISION. + DISPLAY "Enter 'y' if multiple presses of the END key" + LINE 1 COLUMN 1. + DISPLAY "go to the end of the field and just after the end" + LINE 2 COLUMN 1. + DISPLAY "of the characters." + LINE 3 COLUMN 1. + + MOVE " ABC " TO WS-X-20. + ACCEPT WS-X-20 + LINE 5 COLUMN 1 + WITH + AUTO-SKIP + SIZE 10 + UPDATE. + + ACCEPT SUCCESS-FLAG + LINE 7 COLUMN 1 + WITH UPDATE. + + IF success AND COB-CRT-STATUS = 0 + GOBACK RETURNING 0 + ELSE + GOBACK RETURNING 1 + END-IF + . +]) + +AT_CHECK([$COMPILE prog.cob], [0], [], []) +MANUAL_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) + +AT_CLEANUP + + +AT_SETUP([INSERT key]) +AT_KEYWORDS([COB_INSERT_MODE SIZE]) + +AT_SKIP_IF([test "$COB_HAS_CURSES" != "yes"]) + +AT_DATA([prog.cob], [ + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 success-flag PIC X VALUE 'Y'. + 88 success VALUE 'Y', 'y'. + 01 ws-x-20 PIC X(20). + PROCEDURE DIVISION. + DISPLAY "Enter 'y' if multiple presses of the INSERT key" + LINE 1 COLUMN 1. + DISPLAY "go back and forth between" + LINE 2 COLUMN 1. + DISPLAY "Insert Mode ON (characters move to the right)" + LINE 3 COLUMN 1. + DISPLAY "and Insert Mode OFF (characters type over)." + LINE 4 COLUMN 1. + + MOVE "ABCD " TO WS-X-20. + ACCEPT WS-X-20 + LINE 6 COLUMN 1 + WITH + AUTO-SKIP + SIZE 10 + UPDATE. + + ACCEPT SUCCESS-FLAG + LINE 8 COLUMN 1 + WITH UPDATE. + + IF success AND COB-CRT-STATUS = 0 + GOBACK RETURNING 0 + ELSE + GOBACK RETURNING 1 + END-IF + . +]) + +AT_CHECK([$COMPILE prog.cob], [0], [], []) +MANUAL_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) + +AT_CLEANUP + + +AT_SETUP([cursor visibility]) +AT_KEYWORDS([COB_HIDE_CURSOR]) + +AT_SKIP_IF([test "$COB_HAS_CURSES" != "yes"]) + +AT_DATA([prog.cob], [ + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 success-flag PIC X VALUE 'Y'. + 88 fail VALUE 'N'. + 01 ws-input PIC X. + 88 success VALUE 'Y', 'y'. + PROCEDURE DIVISION. + DISPLAY "Type 'Y' if you see the cursor" + LINE 1 COLUMN 1. + + ACCEPT WS-INPUT + LINE 1 COLUMN 50 + WITH AUTO-SKIP + UPDATE. + IF NOT success SET fail TO TRUE. + + SET ENVIRONMENT 'COB_HIDE_CURSOR' TO 'TRUE'. + + DISPLAY "Type 'Y' if you do not see the cursor" + LINE 3 COLUMN 1. + + ACCEPT WS-INPUT + LINE 3 COLUMN 50 + WITH AUTO-SKIP + UPDATE. + IF NOT success SET fail TO TRUE. + + SET ENVIRONMENT 'COB_INSERT_MODE' TO 'TRUE'. + + DISPLAY "Type 'Y' if you still do not see the cursor" + LINE 5 COLUMN 1. + + ACCEPT WS-INPUT + LINE 5 COLUMN 50 + WITH AUTO-SKIP + UPDATE. + IF NOT success SET fail TO TRUE. + + IF fail + GOBACK RETURNING 1 + ELSE + GOBACK RETURNING 0 + END-IF + . +]) + +AT_CHECK([$COMPILE prog.cob], [0], [], []) +MANUAL_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) + +AT_CLEANUP + + +AT_SETUP([BACKSPACE key]) +AT_KEYWORDS([SIZE CURSOR position]) + +AT_SKIP_IF([test "$COB_HAS_CURSES" != "yes"]) + +AT_DATA([prog.cob], [ + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + ENVIRONMENT DIVISION. + CONFIGURATION SECTION. + SPECIAL-NAMES. + CURSOR IS cur-pos. + DATA DIVISION. + WORKING-STORAGE SECTION. + 77 cur-pos pic 9(06). + 01 success-flag PIC X VALUE 'Y'. + 88 success VALUE 'Y', 'y'. + 01 ws-x-20 PIC X(20). + PROCEDURE DIVISION. + DISPLAY "Enter 'y' if each press of the BACKSPACE key" + LINE 1 COLUMN 1. + DISPLAY "deletes the character to the left and moves the" + LINE 2 COLUMN 1. + DISPLAY "cursor and remaining characters one space to the" + LINE 3 COLUMN 1. + DISPLAY "left." + LINE 4 COLUMN 1. + + MOVE "ABCD " TO WS-X-20. + MOVE 006002 TO cur-pos. + ACCEPT WS-X-20 + LINE 6 COLUMN 1 + WITH + AUTO-SKIP + SIZE 10 + UPDATE. + + ACCEPT SUCCESS-FLAG + LINE 8 COLUMN 1 + WITH UPDATE. + + IF success AND COB-CRT-STATUS = 0 + GOBACK RETURNING 0 + ELSE + GOBACK RETURNING 1 + END-IF + . +]) + +AT_CHECK([$COMPILE prog.cob], [0], [], []) +MANUAL_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) + +AT_CLEANUP + + +AT_SETUP([DELETE key]) +AT_KEYWORDS([SIZE position]) + +AT_SKIP_IF([test "$COB_HAS_CURSES" != "yes"]) + +AT_DATA([prog.cob], [ + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 success-flag PIC X VALUE 'Y'. + 88 success VALUE 'Y', 'y'. + 01 ws-x-20 PIC X(20). + PROCEDURE DIVISION. + DISPLAY "Enter 'y' if each press of the DELETE key deletes" + LINE 1 COLUMN 1. + DISPLAY "the cursor character and moves the remaining" + LINE 2 COLUMN 1. + DISPLAY "characters one space to the left. And the cursor" + LINE 3 COLUMN 1. + DISPLAY "does not move." + LINE 4 COLUMN 1. + + MOVE "ABCD " TO WS-X-20. + ACCEPT WS-X-20 + LINE 6 COLUMN 1 + WITH + AUTO-SKIP + SIZE 10 + UPDATE. + + ACCEPT SUCCESS-FLAG + LINE 8 COLUMN 1 + WITH UPDATE. + + IF success AND COB-CRT-STATUS = 0 + GOBACK RETURNING 0 + ELSE + GOBACK RETURNING 1 + END-IF + . +]) + +AT_CHECK([$COMPILE prog.cob], [0], [], []) +MANUAL_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) + +AT_CLEANUP + + +AT_SETUP([ALT DELETE key]) +AT_KEYWORDS([ALT-DELETE SIZE]) + +AT_SKIP_IF([test "$COB_HAS_CURSES" != "yes"]) + +AT_DATA([prog.cob], [ + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 success-flag PIC X VALUE 'Y'. + 88 success VALUE 'Y', 'y'. + 01 ws-x-20 PIC X(20). + PROCEDURE DIVISION. + DISPLAY "Enter 'y' if pressing the ALT and DELETE keys" + LINE 1 COLUMN 1. + DISPLAY "deletes all characters from the cursor to the end" + LINE 2 COLUMN 1. + DISPLAY "of the field. And the cursor does not move." + LINE 3 COLUMN 1. + + MOVE "ABCD " TO WS-X-20. + ACCEPT WS-X-20 + LINE 5 COLUMN 1 + WITH + AUTO-SKIP + SIZE 10 + UPDATE. + + ACCEPT SUCCESS-FLAG + LINE 7 COLUMN 1 + WITH UPDATE. + + IF success AND COB-CRT-STATUS = 0 + GOBACK RETURNING 0 + ELSE + GOBACK RETURNING 1 + END-IF + . +]) + +AT_CHECK([$COMPILE prog.cob], [0], [], []) +MANUAL_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) + +AT_CLEANUP + + +AT_SETUP([ALT LEFT-ARROW key]) +AT_KEYWORDS([ALT-LEFT-ARROW SIZE]) + +AT_SKIP_IF([test "$COB_HAS_CURSES" != "yes"]) + +AT_DATA([prog.cob], [ + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 success-flag PIC X VALUE 'Y'. + 88 success VALUE 'Y', 'y'. + 01 ws-x-20 PIC X(20). + PROCEDURE DIVISION. + DISPLAY "Enter 'y' if pressing the ALT and LEFT-ARROW keys" + LINE 1 COLUMN 1. + DISPLAY "at the first column does not exit the field." + LINE 2 COLUMN 1. + DISPLAY "But the LEFT-ARROW without ALT does exit." + LINE 3 COLUMN 1. + + MOVE "ABCD " TO WS-X-20. + ACCEPT WS-X-20 + LINE 5 COLUMN 1 + WITH + AUTO-SKIP + SIZE 10 + UPDATE. + + ACCEPT SUCCESS-FLAG + LINE 7 COLUMN 1 + WITH UPDATE. + + IF success AND COB-CRT-STATUS = 0 + GOBACK RETURNING 0 + ELSE + GOBACK RETURNING 1 + END-IF + . +]) + +AT_CHECK([$COMPILE prog.cob], [0], [], []) +MANUAL_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) + +AT_CLEANUP + + +AT_SETUP([ALT RIGHT-ARROW key]) +AT_KEYWORDS([SIZE]) + +AT_SKIP_IF([test "$COB_HAS_CURSES" != "yes"]) + +AT_DATA([prog.cob], [ + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 success-flag PIC X VALUE 'Y'. + 88 success VALUE 'Y', 'y'. + 01 ws-x-10 PIC X(10). + PROCEDURE DIVISION. + DISPLAY "Enter 'y' if pressing the ALT and RIGHT-ARROW keys" + LINE 1 COLUMN 1. + DISPLAY "at the last column does not exit the field." + LINE 2 COLUMN 1. + DISPLAY "But the RIGHT-ARROW without ALT does exit." + LINE 3 COLUMN 1. + + MOVE "ABCDE" TO WS-X-10. + ACCEPT WS-X-10 + LINE 5 COLUMN 1 + WITH + AUTO-SKIP + SIZE 5 + UPDATE. + + ACCEPT SUCCESS-FLAG + LINE 7 COLUMN 1 + WITH UPDATE. + + IF success AND COB-CRT-STATUS = 0 + GOBACK RETURNING 0 + ELSE + GOBACK RETURNING 1 + END-IF + . +]) + +AT_CHECK([$COMPILE prog.cob], [0], [], []) +MANUAL_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) + +AT_CLEANUP + + +AT_SETUP([CURSOR clause]) +AT_KEYWORDS([SPECIAL-NAMES]) + +AT_SKIP_IF([test "$COB_HAS_CURSES" != "yes"]) + +AT_DATA([prog1.cob], [ + identification division. + program-id. prog. + + environment division. + configuration section. + special-names. + cursor is my-cur. + data division. + working-storage section. + + 01 my-cur. + 05 my-row pic 9(3) value 0. + 05 my-col pic 9(3) value 0. + + 77 loop pic 99. + 77 cursor-moves-here pic x(20). + + screen section. + + 01 screen-example . + 05 message1 value is "row (view only) is " line 1 col 10. + 05 filler pic 9(3) from my-row. + + 05 message2 value is "col (adjust only) is " line 2 col 10. + 05 filler pic 9(3) using my-col. + + 05 filler pic x(20) using cursor-moves-here line 3 col 14. + + procedure division. + + perform varying loop from 1 by 1 + until loop > 10 + display "screen accept no. " + at line 10 col 4 + loop "/10" + display screen-example + accept screen-example + end-perform + + goback. +]) + +# note: same test, but this time with different specified +# special-names reference +AT_DATA([prog2.cob], [ + identification division. + program-id. prog. + + data division. + working-storage section. + + 01 my-cur is special-names cursor. + 05 my-row pic 9(3) value 0. + 05 my-col pic 9(3) value 0. + + 77 loop pic 99. + 77 cursor-moves-here pic x(20). + + screen section. + + 01 screen-example . + 05 message1 value is "row (view only) is " line 1 col 10. + 05 filler pic 9(3) from my-row. + + 05 message2 value is "col (adjust only) is " line 2 col 10. + 05 filler pic 9(3) using my-col. + + 05 filler pic x(20) using cursor-moves-here line 3 col 14. + + procedure division. + + perform varying loop from 1 by 1 + until loop > 10 + display "screen accept no. " + at line 10 col 4 + loop "/10" + display screen-example + accept screen-example + end-perform + + goback. +]) + +AT_CHECK([$COMPILE prog1.cob], [0], [], []) +AT_CHECK([$COMPILE prog2.cob], [0], [], []) + +# user-instructions what to test is missing +AT_SKIP_IF([true]) + +MANUAL_CHECK([$COBCRUN_DIRECT ./prog1], [0], [], []) +MANUAL_CHECK([$COBCRUN_DIRECT ./prog2], [0], [], []) + +AT_CLEANUP + + +AT_SETUP([CRT STATUS clause]) +AT_KEYWORDS([SPECIAL-NAMES]) + +AT_SKIP_IF([test "$COB_HAS_CURSES" != "yes"]) + +AT_DATA([prog1.cob], [ + identification division. + program-id. prog. + + environment division. + configuration section. + special-names. + crt status is my-status. + data division. + working-storage section. + + 01 my-status. + 05 one pic X. + 05 two pic X. + 05 three pic X. + 05 four pic X. + + 77 loop pic 99. + 77 test-field pic x(5). + + screen section. + + 01 screen-example . + 05 message1 value is "status: " line 1 col 10. + 05 filler pic x(4) from my-status. + + 05 message2 value is "test-field: " line 2 col 10. + 05 filler pic x(5) using test-field. + + procedure division. + + set environment 'COB_SCREEN_EXCEPTIONS' to 'TRUE' + set environment 'COB_SCREEN_ESC' to 'TRUE' + perform varying loop from 1 by 1 + until loop > 10 + display "screen accept no. " + at line 10 col 4 + loop "/10" + display screen-example + accept screen-example + end-perform + + goback. +]) + +# note: same test, but this time with different specified +# special-names reference +AT_DATA([prog2.cob], [ + identification division. + program-id. prog. + + data division. + working-storage section. + + 77 my-status pic 9(05) is special-names crt status. + + 77 loop pic 99. + 77 test-field pic x(5). + + screen section. + + 01 screen-example . + 05 message1 value is "status: " line 1 col 10. + 05 filler pic 9(05) from my-status. + + 05 message2 value is "test-field: " line 2 col 10. + 05 filler pic x(5) using test-field. + + procedure division. + + set environment 'COB_SCREEN_EXCEPTIONS' to 'TRUE' + set environment 'COB_SCREEN_ESC' to 'TRUE' + perform varying loop from 1 by 1 + until loop > 10 + display "screen accept no. " + at line 10 col 4 + loop "/10" + display screen-example + accept screen-example + end-perform + + goback. +]) + +AT_CHECK([$COMPILE prog1.cob], [0], [], []) +AT_CHECK([$COMPILE prog2.cob], [0], [], []) + +# user-instructions what to test is missing +AT_SKIP_IF([true]) + +MANUAL_CHECK([$COBCRUN_DIRECT ./prog1], [0], [], []) +MANUAL_CHECK([$COBCRUN_DIRECT ./prog2], [0], [], []) + +AT_CLEANUP + + +AT_SETUP([CRT STATUS clause]) +AT_KEYWORDS([SPECIAL-NAMES]) + +AT_SKIP_IF([test "$COB_HAS_CURSES" != "yes"]) + +AT_DATA([prog.cob], [ + identification division. + program-id. prog-crt4. + + data division. + working-storage section. + + 01 crt4 pic 9(4) is special-names crt status. + + 01 test-tab. + 05 test-01 pic x(20) value "Function key 01 1001". + 05 test-02 pic x(20) value "Function key 02 1002". + 05 test-03 pic x(20) value "Function key 03 1003". + 05 test-04 pic x(20) value "Function key 04 1004". + 05 test-05 pic x(20) value "Function key 05 1005". + 05 test-06 pic x(20) value "Prev-page key 2001". + 05 test-07 pic x(20) value "Next-page key 2002". + + 01 test-rab-r redefines test-tab. + 05 test-data occurs 7 times. + 10 test-name pic x(16). + 10 test-crt4 pic 9(4). + + 01 linenr pic 9(2) value 0. + + 01 test-result-4 pic 9(4). + + 01 return-value pic 9 value 0. + + 77 loop pic 9(2). + 77 test-field pic x. + + + procedure division. + + set environment 'COB_SCREEN_EXCEPTIONS' to 'TRUE' + set environment 'COB_SCREEN_ESC' to 'TRUE' + + perform forever + display spaces with blank screen + + move 0 to return-value + perform varying loop from 1 by 1 until loop > 7 + compute linenr = loop + 5 + + display "Please press " line linenr, column 1 + display test-name(loop) line linenr, column 14 + + move spaces to test-field + accept test-field + line linenr column 30 + + display crt4 line linenr, column 30 + + if crt4 = test-crt4(loop) + display "passed" line linenr, column 36 + else + move 1 to return-value + display "failed" line linenr, column 36 + end-if + end-perform + + if return-value = 0 + exit perform + end-if + + display "Try again? (Y/n) " line 20, column 1 + move "Y" to test-field + accept test-field line 20, column 18 + if not (test-field = "Y" or "y") + exit perform + end-if + end-perform + + goback returning return-value + . +]) + +AT_CHECK([$COMPILE prog.cob], [0], [], []) + +MANUAL_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) + +AT_CLEANUP + + +AT_SETUP([X/Open CRT STATUS clause]) +AT_KEYWORDS([SPECIAL-NAMES]) + +AT_SKIP_IF([test "$COB_HAS_CURSES" != "yes"]) + +AT_DATA([prog.cob], [ + identification division. + program-id. prog-crt3. + + data division. + working-storage section. + + 01 crt3 is special-names crt status. + 05 crt3-1 pic 9. + 05 crt3-2 usage binary-char unsigned. + 05 crt3-3 usage binary-char unsigned. + + 01 test-tab. + 05 test-01 pic x(20) value "Function key 01 1001". + 05 test-02 pic x(20) value "Function key 02 1002". + 05 test-03 pic x(20) value "Function key 03 1003". + 05 test-04 pic x(20) value "Function key 04 1004". + 05 test-05 pic x(20) value "Function key 05 1005". + 05 test-06 pic x(20) value "Prev-page key 2001". + 05 test-07 pic x(20) value "Next-page key 2002". + + 01 test-rab-r redefines test-tab. + 05 test-data occurs 7 times. + 10 test-name pic x(16). + 10 test-crt31 pic 9. + 10 test-crt32 pic 9(3). + + 01 linenr pic 9(2) value 0. + + 01 test-result-1 pic 9. + 01 test-result-3 pic 9(3). + + 01 return-value pic 9 value 0. + + 77 loop pic 9(2). + 77 test-field pic x. + + + procedure division. + + set environment 'COB_SCREEN_EXCEPTIONS' to 'TRUE' + set environment 'COB_SCREEN_ESC' to 'TRUE' + + perform forever + display spaces with blank screen + + move 0 to return-value + perform varying loop from 1 by 1 until loop > 7 + compute linenr = loop + 5 + + display "Please press " line linenr, column 1 + display test-name(loop) line linenr, column 14 + + move spaces to test-field + accept test-field + line linenr column 30 + + move crt3-1 to test-result-1 + display test-result-1 line linenr, column 30 + + move crt3-2 to test-result-3 + display test-result-3 line linenr, column 32 + + if test-result-1 = test-crt31(loop) and + test-result-3 = test-crt32(loop) + display "passed" line linenr, column 36 + else + move 1 to return-value + display "failed" line linenr, column 36 + end-if + end-perform + + if return-value = 0 + exit perform + end-if + + display "Try again? (Y/n) " line 20, column 1 + move "Y" to test-field + accept test-field line 20, column 18 + if not (test-field = "Y" or "y") + exit perform + end-if + end-perform + + goback returning return-value + . +]) + +AT_CHECK([$COMPILE prog.cob], [0], [], []) + +MANUAL_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) + +AT_CLEANUP + +AT_SETUP([simple ACCEPT field WITH UPDATE]) +AT_KEYWORDS([screen]) + +AT_SKIP_IF([test "$COB_HAS_CURSES" != "yes"]) + +AT_DATA([prog.cob], [ + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 77 var pic x(11) value 'ignore this'. + 01 success-flag PIC X VALUE 'y'. + 88 success VALUE 'Y', 'y'. + + PROCEDURE DIVISION. + display "Press ENTER if you see an ""y"" " + at 0302 + accept success-flag update. + + IF success AND COB-CRT-STATUS = 0 + GOBACK RETURNING 0 + ELSE + GOBACK RETURNING 1 + END-IF + . +]) + +AT_CHECK([$COMPILE prog.cob], [0], [], []) +MANUAL_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) + +AT_CLEANUP + + +AT_SETUP([VALUE ALL in SCREEN SECTION]) + +AT_SKIP_IF([test "$COB_HAS_CURSES" != "yes"]) + +AT_DATA([prog.cob], [ + IDENTIFICATION DIVISION. + PROGRAM-ID. SCREEN-VALUE-ALL. + + DATA DIVISION. + WORKING-STORAGE SECTION. + + SCREEN SECTION. + 01 SCREEN001 BLANK SCREEN AUTO-SKIP. + 03 SCR01 BACKGROUND-COLOR 2 FOREGROUND-COLOR 7. + 05 LINE 02 COL 001 PIC X(50) VALUE ALL '-'. + + PROCEDURE DIVISION. + DISPLAY 'Press ENTER if you see a sequence of ""-""' + AT 0101 END-DISPLAY + DISPLAY ' ' AT 0201 END-DISPLAY + ACCEPT SCREEN001 + ACCEPT OMITTED + GOBACK. +]) + +AT_CHECK([$COMPILE prog.cob], [0], [], []) +MANUAL_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) + +AT_CLEANUP + + +AT_SETUP([CURSOR position in line 1]) +AT_KEYWORDS([screen]) + +AT_SKIP_IF([test "$COB_HAS_CURSES" != "yes"]) + +AT_DATA([prog.cob], [ + IDENTIFICATION DIVISION. + PROGRAM-ID. PROG. + ENVIRONMENT DIVISION. + CONFIGURATION SECTION. + SPECIAL-NAMES. + CURSOR IS CURSOR-POSITION. + + DATA DIVISION. + + WORKING-STORAGE SECTION. + + 01 CURSOR-POSITION. + 05 CSR-ROW-NUMBER PIC 9(03) VALUE 001. + 05 CSR-COL-NUMBER PIC 9(03) VALUE 005. + + 01 WORK-FIELDS. + 05 IN-ID PIC X(09) VALUE SPACES. + 05 TRAN-ID PIC X(03) VALUE 'ABC'. + + 01 SUCCESS-FLAG PIC X VALUE 'Y'. + 88 SUCCESS VALUE 'y', 'Y'. + + SCREEN SECTION. + + 01 EMPLOYEE-SCREEN + BACKGROUND-COLOR IS 0 + FOREGROUND-COLOR IS 7. + + 05 LINE 01 COL 01 AUTO PIC X(03) USING + TRAN-ID. + 05 LINE 01 COL 04 PIC X(01) VALUE + ','. + 05 LINE 01 COL 05 AUTO PIC X(09) USING + IN-ID. + + 05 LINE 5 VALUE 'cursor should be ' + & 'at line 1 and column 5'. + 05 LINE 6 VALUE 'go to line 10 ' + & 'and enter an "y" or "n" '. + 05 LINE 10 PIC X, REQUIRED USING success-flag. + + PROCEDURE DIVISION. + + DISPLAY EMPLOYEE-SCREEN. + ACCEPT EMPLOYEE-SCREEN. + + IF SUCCESS AND COB-CRT-STATUS = 0 + GOBACK RETURNING 0 + ELSE + GOBACK RETURNING 1 + END-IF. + +]) + +AT_CHECK([$COMPILE prog.cob], [0], [], []) +MANUAL_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) + +AT_CLEANUP + + +AT_SETUP([ACCEPT SCREEN TIMEOUT]) +AT_KEYWORDS([crt status cursor]) + +AT_SKIP_IF([test "$COB_HAS_CURSES" != "yes"]) + +AT_DATA([prog.cob], [ + REPLACE ==:BCOL:== BY ==BACKGROUND-COLOR==; ==:FCOL:== BY + ==FOREGROUND-COLOR==. + ** ************************************************************* + ** + ** ************************************************************* + IDENTIFICATION DIVISION. + PROGRAM-ID. PROG. + * GnuCOBOL sample + ENVIRONMENT DIVISION. + CONFIGURATION SECTION. + SPECIAL-NAMES. + CRT STATUS IS WCRT-STATUS. + CURSOR IS WCURSORROWCOL. + DATA DIVISION. + + WORKING-STORAGE SECTION. + 77 K-ENTER PIC 9(04) VALUE 0000. + 77 K-TIMEOUT PIC 9(04) VALUE 8001. + + 01 WCRT-STATUS PIC 9(04) VALUE ZERO. + 01 WCURSORROWCOL PIC 9(06) VALUE 000000. + 01 REDEFINES WCURSORROWCOL . + 05 WCURSORROW PIC 9(03). + 05 WCURSORCOL PIC 9(03). + 01 BLACK CONSTANT AS 00. + 01 BLUE CONSTANT AS 01. + 01 GREEN CONSTANT AS 02. + 01 CYAN CONSTANT AS 03. + 01 RED CONSTANT AS 04. + 01 MAGENTA CONSTANT AS 05. + * old color code as yellow + 01 BROWN CONSTANT AS 06. + * or Light Gray + 01 WHITE CONSTANT AS 07. + * or Dark Gray + 01 GREY CONSTANT AS 08. + * same color code as Grey + 01 LIGHTBLACK CONSTANT AS 08. + 01 LIGHTBLUE CONSTANT AS 09. + 01 LIGHTGREEN CONSTANT AS 10. + 01 LIGHTCYAN CONSTANT AS 11. + 01 LIGHTRED CONSTANT AS 12. + 01 LIGHTMAGENTA CONSTANT AS 13. + 01 PINK CONSTANT AS 13. + 01 YELLOW CONSTANT AS 14. + 01 LIGHTWHITE CONSTANT AS 15. + + + + 01 W-VAR-SELECTION. + 02 W-DATA PIC X(8). + 02 W-REPLY PIC X(01). + 88 SUCCESS VALUE 'Y', 'y'. + + + SCREEN SECTION. + + 01 SCREEN-SELECTION. + 02 LINE 06 COL 05 :FCOL: BLACK :BCOL: CYAN + VALUE 'TIMEOUT TEST - ENTER 4 CHARACTERS OF DATA' & + ' AND PAUSE UNTIL TIME CHANGES'. + 02 LINE 07 COL 05 :FCOL: BLACK :BCOL: CYAN + VALUE ' THEN ENTER 4 MORE CHARACTERS OF DATA' & + ' AND PAUSE UNTIL TIME CHANGES'. + 02 LINE 08 COL 05 :FCOL: BLACK :BCOL: CYAN + VALUE ' THEN AFTER THE TIME CHANGES ' & + ' ENTER A Y IN THE REPY LINE IF THE DATA ' & + ' IS CORRECT'. + + 02 LINE 15 COL 20 VALUE 'Data Entry:'. + 02 LINE + 2 COL 20 VALUE 'Reply:'. + 02 LINE 15 COL 40 PIC A(08) AUTO-SKIP USING W-DATA + HIGHLIGHT. + 02 LINE + 2 COL 40 PIC X AUTO-SKIP USING W-REPLY + HIGHLIGHT. + + PROCEDURE DIVISION. + + MAIN-LOOP. + DISPLAY SCREEN-SELECTION + CALL 'TIMEDISP' + + PERFORM WITH TEST AFTER UNTIL WCRT-STATUS <> K-TIMEOUT + ACCEPT SCREEN-SELECTION WITH TIMEOUT 1 + ON EXCEPTION CALL 'TIMEDISP' + END-ACCEPT + END-PERFORM. + + IF SUCCESS AND WCRT-STATUS = 0 + GOBACK RETURNING 0 + ELSE + GOBACK RETURNING 1 + END-IF + . + + GOBACK. + + ** ************************************************************* + * + ** ************************************************************* + ID DIVISION. + PROGRAM-ID. TIMEDISP. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 SWITCH PIC X. + 01 BLUE CONSTANT AS 01. + 01 RED CONSTANT AS 04. + 01 CYAN CONSTANT AS 03. + 01 WHITE CONSTANT AS 07. + 01 WDAY PIC 9(08). + 01 WTIME PIC 9(08). + 01 DATE-TIME PIC X(19). + PROCEDURE DIVISION. + ACCEPT WDAY FROM DATE YYYYMMDD + ACCEPT WTIME FROM TIME + STRING WDAY(1:4) '.' WDAY(5:2) '.' WDAY(7:2) ' ' + WTIME(1:2) ':' WTIME(3:2) ':' WTIME(5:2) DELIMITED BY + SIZE INTO DATE-TIME + IF SWITCH EQUAL 'N' + DISPLAY DATE-TIME AT 002061 :BCOL: CYAN :FCOL: WHITE + END-DISPLAY + MOVE 'Y' TO SWITCH + ELSE + DISPLAY DATE-TIME AT 002061 :BCOL: RED :FCOL: WHITE + END-DISPLAY + MOVE 'N' TO SWITCH + END-IF. + CONTINUE. + ENDPROGRAM. + GOBACK. + END PROGRAM TIMEDISP. + + END PROGRAM PROG. +]) + +AT_CHECK([$COMPILE prog.cob], [0], [], []) +MANUAL_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) + +AT_CLEANUP + + +AT_SETUP([system function CBL_GC_WINDOW]) +AT_KEYWORDS([screen]) + +AT_SKIP_IF([test "$COB_HAS_CURSES" != "yes"]) + +AT_DATA([prog.cob], [ +GNU >>SOURCE FORMAT IS FIXED +COBOL *> *************************************************************** + *> DATE: 20200630 + *> LICENSE: PUBLIC DOMAIN +COLORS*> PURPOSE: SHOW THE GNUCOBOL DEFAULT COLOUR PALETTE + *> TECTONICS: COBC -X GNUCOBOL-COLOURS.COB + *> *************************************************************** + IDENTIFICATION DIVISION. + PROGRAM-ID. SAMPLE. + + ENVIRONMENT DIVISION. + CONFIGURATION SECTION. + *SOURCE-COMPUTER. IBM-PC WITH DEBUGGING MODE. + OBJECT-COMPUTER. IBM-PC. + + REPOSITORY. + FUNCTION ALL INTRINSIC. + + DATA DIVISION. + WORKING-STORAGE SECTION. + + 01 BLACK CONSTANT AS 0. + 01 BLUE CONSTANT AS 1. + 01 GREEN CONSTANT AS 2. + 01 CYAN CONSTANT AS 3. + 01 RED CONSTANT AS 4. + 01 MAGENTA CONSTANT AS 5. + 01 BROWN CONSTANT AS 6. + 01 WHITE CONSTANT AS 7. + + 77 ANSWER-TEXT PIC X. + + 01 SW-EVEN PIC X VALUE 'N'. + 01 CNTR PIC S9(9) COMP-5 VALUE +0. + 01 CNTR-ROW PIC S9(9) COMP-5 VALUE +0. + 01 CNTR-COL PIC S9(9) COMP-5 VALUE +0. + + 01 CURSOR-LOCN-BUFFER. + 05 CURSOR-LINE USAGE BINARY-CHAR UNSIGNED. + 05 CURSOR-COLUMN USAGE BINARY-CHAR UNSIGNED. + + 01 TMP. + 05 TMP-LINE PIC 9(4) COMP-5. + 05 TMP-COLUMN PIC 9(4) COMP-5. + + COPY 'gcwindow'. + + SCREEN SECTION. + 01 GNUCOBOL-COLOURS. + 05 LINE 1 COLUMN 1 VALUE "GNUCOBOL COLOURS". + 05 LINE 2 COLUMN 1 VALUE "==================". + + 05 LINE 4 COLUMN 1 VALUE "DEFAULT HIGHLIGHT " + & "LOWLIGHT REVERSE-VIDEO ". + 05 LINE 5 COLUMN 1 VALUE "------------------------------" + & "------------------------------". + + 05 LINE 7 COLUMN 1 VALUE "BLACK " FOREGROUND-COLOR BLACK. + 05 LINE + 1 COLUMN 1 VALUE "BLUE " FOREGROUND-COLOR BLUE. + 05 LINE + 1 COLUMN 1 VALUE "GREEN " FOREGROUND-COLOR GREEN. + 05 LINE + 1 COLUMN 1 VALUE "CYAN " FOREGROUND-COLOR CYAN. + 05 LINE + 1 COLUMN 1 VALUE "RED " FOREGROUND-COLOR RED. + 05 LINE + 1 COLUMN 1 VALUE "MAGENTA" FOREGROUND-COLOR MAGENTA. + 05 LINE + 1 COLUMN 1 VALUE "BROWN " FOREGROUND-COLOR BROWN. + 05 LINE + 1 COLUMN 1 VALUE "WHITE " FOREGROUND-COLOR WHITE. + *>BACKGROUND-COLOR BLACK. + + 05 LINE 7 COLUMN 16 VALUE "BLACK " + HIGHLIGHT FOREGROUND-COLOR BLACK. + *>BACKGROUND-COLOR WHITE. + 05 LINE + 1 COLUMN 16 VALUE "BLUE " + HIGHLIGHT FOREGROUND-COLOR BLUE. + 05 LINE + 1 COLUMN 16 VALUE "GREEN " + HIGHLIGHT FOREGROUND-COLOR GREEN. + 05 LINE + 1 COLUMN 16 VALUE "CYAN " + HIGHLIGHT FOREGROUND-COLOR CYAN. + 05 LINE + 1 COLUMN 16 VALUE "RED " + HIGHLIGHT FOREGROUND-COLOR RED. + 05 LINE + 1 COLUMN 16 VALUE "MAGENTA" + HIGHLIGHT FOREGROUND-COLOR MAGENTA. + 05 LINE + 1 COLUMN 16 VALUE "BROWN " + HIGHLIGHT FOREGROUND-COLOR BROWN. + 05 LINE + 1 COLUMN 16 VALUE "WHITE " + HIGHLIGHT FOREGROUND-COLOR WHITE + BACKGROUND-COLOR BLACK. + + 05 LINE 7 COLUMN 31 VALUE "BLACK " + LOWLIGHT FOREGROUND-COLOR BLACK. + *>BACKGROUND-COLOR WHITE. + 05 LINE + 1 COLUMN 31 VALUE "BLUE " + LOWLIGHT FOREGROUND-COLOR BLUE. + 05 LINE + 1 COLUMN 31 VALUE "GREEN " + LOWLIGHT FOREGROUND-COLOR GREEN. + 05 LINE + 1 COLUMN 31 VALUE "CYAN " + LOWLIGHT FOREGROUND-COLOR CYAN. + 05 LINE + 1 COLUMN 31 VALUE "RED " + LOWLIGHT FOREGROUND-COLOR RED. + 05 LINE + 1 COLUMN 31 VALUE "MAGENTA" + LOWLIGHT FOREGROUND-COLOR MAGENTA. + 05 LINE + 1 COLUMN 31 VALUE "BROWN " + LOWLIGHT FOREGROUND-COLOR BROWN. + 05 LINE + 1 COLUMN 31 VALUE "WHITE " + LOWLIGHT FOREGROUND-COLOR WHITE. + *>BACKGROUND-COLOR BLACK. + + 05 LINE 7 COLUMN 46 VALUE "BLACK " + REVERSE-VIDEO FOREGROUND-COLOR BLACK. + *>BACKGROUND-COLOR WHITE. + 05 LINE + 1 COLUMN 46 VALUE "BLUE " + REVERSE-VIDEO FOREGROUND-COLOR BLUE. + 05 LINE + 1 COLUMN 46 VALUE "GREEN " + REVERSE-VIDEO FOREGROUND-COLOR GREEN. + 05 LINE + 1 COLUMN 46 VALUE "CYAN " + REVERSE-VIDEO FOREGROUND-COLOR CYAN. + 05 LINE + 1 COLUMN 46 VALUE "RED " + REVERSE-VIDEO FOREGROUND-COLOR RED. + 05 LINE + 1 COLUMN 46 VALUE "MAGENTA" + REVERSE-VIDEO FOREGROUND-COLOR MAGENTA. + 05 LINE + 1 COLUMN 46 VALUE "BROWN " + REVERSE-VIDEO FOREGROUND-COLOR BROWN. + 05 LINE + 1 COLUMN 46 VALUE "WHITE " + REVERSE-VIDEO FOREGROUND-COLOR WHITE. + *>BACKGROUND-COLOR BLACK. + + *> *************************************************************** + PROCEDURE DIVISION. + + MOVE ZERO TO CNTR. + * DISPLAY ' ' AT LINE 1 COLUMN 1. + CALL 'CBL_GC_SET_SCR_SIZE' USING 50, 80. + + DISPLAY ' YOU WILL SEE 4 WINDOWS OF ALTERNATING COLORS ' & + 'WAIT UNTIL THE END TO ANSWER-TEXT PROMPT' + AT LINE 1 COL 4. + + D DISPLAY ' ' UPON SYSERR + D DISPLAY ' STARTING NEW WINDOWS ' UPON SYSERR + D DISPLAY ' ' UPON SYSERR + + PERFORM 4 TIMES + ADD +5 TO CNTR + MOVE CNTR TO WP-WINDOW-START-ROW + MOVE CNTR TO WP-WINDOW-START-COL + MOVE 20 TO WP-WINDOW-ROWS + MOVE 60 TO WP-WINDOW-COLUMNS + IF SW-EVEN EQUAL 'Y' + MOVE 'N' TO SW-EVEN + MOVE 0 TO WP-WINDOW-FG-COLOR + MOVE 6 TO WP-WINDOW-BG-COLOR + ELSE + MOVE 'Y' TO SW-EVEN + MOVE 0 TO WP-WINDOW-FG-COLOR + MOVE 3 TO WP-WINDOW-BG-COLOR + END-IF + MOVE ZERO TO WP-WINDOW-HIDDEN + SET WP-MODE-NEW-WINDOW TO TRUE + PERFORM 1000-WINDOW-FUNCTION THRU 1000-EXIT + CALL 'CBL_GC_WINDOW' USING WL-WINDOW-LIST + PERFORM 3000-LIST-WINDOWS THRU 3000-EXIT + PERFORM 2000-WINDOW-CSR-POS THRU 2000-EXIT + DISPLAY GNUCOBOL-COLOURS + PERFORM 2000-WINDOW-CSR-POS THRU 2000-EXIT + CALL "C$SLEEP" USING 1 + END-PERFORM. + + + MOVE ZERO TO CNTR. + + D DISPLAY ' ' UPON SYSERR + D DISPLAY ' STARTING HIDE WINDOWS ' UPON SYSERR + D DISPLAY ' ' UPON SYSERR + + PERFORM 4 TIMES + ADD +1 TO CNTR + MOVE CNTR TO WP-WINDOW-NUMBER + MOVE 1 TO WP-WINDOW-HIDDEN + SET WP-MODE-HIDE-WINDOW TO TRUE + PERFORM 1000-WINDOW-FUNCTION THRU 1000-EXIT + CALL 'CBL_GC_WINDOW' USING WL-WINDOW-LIST + PERFORM 3000-LIST-WINDOWS THRU 3000-EXIT + CALL "C$SLEEP" USING 1 + END-PERFORM. + + + MOVE 5 TO CNTR. + + D DISPLAY ' ' UPON SYSERR + D DISPLAY ' STARTING SHOW WINDOWS ' UPON SYSERR + D DISPLAY ' ' UPON SYSERR + + PERFORM 4 TIMES + ADD -1 TO CNTR + MOVE CNTR TO WP-WINDOW-NUMBER + MOVE ZERO TO WP-WINDOW-HIDDEN + SET WP-MODE-SHOW-WINDOW TO TRUE + PERFORM 1000-WINDOW-FUNCTION THRU 1000-EXIT + CALL 'CBL_GC_WINDOW' USING WL-WINDOW-LIST + PERFORM 3000-LIST-WINDOWS THRU 3000-EXIT + CALL "C$SLEEP" USING 1 + PERFORM 2000-WINDOW-CSR-POS THRU 2000-EXIT + END-PERFORM. + + MOVE ZERO TO CNTR. + MOVE 10 TO CNTR-COL. + MOVE 10 TO CNTR-ROW. + + D DISPLAY ' ' UPON SYSERR + D DISPLAY ' STARTING MOVE WINDOWS ' UPON SYSERR + D DISPLAY ' STARTING TOP WINDOWS ' UPON SYSERR + D DISPLAY ' ' UPON SYSERR + + PERFORM 4 TIMES + PERFORM 2000-WINDOW-CSR-POS THRU 2000-EXIT + ADD +1 TO CNTR + ADD +2 TO CNTR-ROW + ADD +2 TO CNTR-COL + MOVE CNTR TO WP-WINDOW-NUMBER + MOVE CNTR-ROW TO WP-WINDOW-START-ROW + MOVE CNTR-COL TO WP-WINDOW-START-COL + MOVE 0 TO WP-WINDOW-HIDDEN + SET WP-MODE-MOVE-WINDOW TO TRUE + PERFORM 1000-WINDOW-FUNCTION THRU 1000-EXIT + CALL 'CBL_GC_WINDOW' USING WL-WINDOW-LIST + PERFORM 3000-LIST-WINDOWS THRU 3000-EXIT + MOVE CNTR TO WP-WINDOW-NUMBER + MOVE 0 TO WP-WINDOW-START-ROW + MOVE 0 TO WP-WINDOW-START-COL + MOVE 0 TO WP-WINDOW-HIDDEN + PERFORM 2000-WINDOW-CSR-POS THRU 2000-EXIT + SET WP-MODE-TOP-WINDOW TO TRUE + PERFORM 1000-WINDOW-FUNCTION THRU 1000-EXIT + PERFORM 2000-WINDOW-CSR-POS THRU 2000-EXIT + CALL "C$SLEEP" USING 1 + END-PERFORM. + + CALL "C$SLEEP" USING 1 + * ACCEPT + * OMITTED + * LINE 16 COLUMN 1 + * END-ACCEPT. + + MOVE ZERO TO CNTR. + + D DISPLAY ' ' UPON SYSERR + D DISPLAY ' STARTING BOTTOM WINDOWS ' UPON SYSERR + D DISPLAY ' ' UPON SYSERR + + PERFORM 4 TIMES + ADD +1 TO CNTR + MOVE CNTR TO WP-WINDOW-NUMBER + MOVE 1 TO WP-WINDOW-HIDDEN + SET WP-MODE-BOTTOM-WINDOW TO TRUE + PERFORM 1000-WINDOW-FUNCTION THRU 1000-EXIT + CALL 'CBL_GC_WINDOW' USING WL-WINDOW-LIST + PERFORM 3000-LIST-WINDOWS THRU 3000-EXIT + * CALL "C$SLEEP" USING 1 + END-PERFORM. + + MOVE ZERO TO CNTR. + + D DISPLAY ' ' UPON SYSERR + D DISPLAY ' STARTING DELETE WINDOWS ' UPON SYSERR + D DISPLAY ' ' UPON SYSERR + + PERFORM 4 TIMES + ADD +1 TO CNTR + MOVE CNTR TO WP-WINDOW-NUMBER + MOVE 1 TO WP-WINDOW-HIDDEN + SET WP-MODE-DELETE-WINDOW TO TRUE + PERFORM 1000-WINDOW-FUNCTION THRU 1000-EXIT + CALL 'CBL_GC_WINDOW' USING WL-WINDOW-LIST + PERFORM 3000-LIST-WINDOWS THRU 3000-EXIT + * CALL "C$SLEEP" USING 1 + END-PERFORM. + + DISPLAY ' DID YOU WILL SEE THEM CREATED, MOVED, HIDDEN, S' & + 'HOWN AND DELETED SUCCESSFULLY ?' + AT LINE 4 COL 4. + DISPLAY 'ANSWER Y OR N' + AT LINE 5 COL 10. + ACCEPT ANSWER-TEXT + AT LINE 5 COL 25. + + IF ANSWER-TEXT EQUAL 'Y' OR 'y' + MOVE ZERO TO RETURN-CODE + ELSE + MOVE 1 TO RETURN-CODE + END-IF. + + GOBACK. + + 1000-WINDOW-FUNCTION. + + CALL 'CBL_GC_WINDOW' USING WP-WINDOW-PARMS. + IF RETURN-CODE NOT EQUAL ZERO + D DISPLAY 'RETURN CODE IS ==> ' RETURN-CODE + D UPON SYSERR + GOBACK + END-IF. + + + 1000-EXIT. EXIT. + + 2000-WINDOW-CSR-POS. + + CALL "CBL_GET_CSR_POS" USING CURSOR-LOCN-BUFFER. + COMPUTE TMP-LINE = CURSOR-LINE + 1. + COMPUTE TMP-COLUMN = CURSOR-COLUMN + 1. + D DISPLAY ' WINDOW ==> ' WP-WINDOW-NUMBER + D ' CURSOR POSITION IS LINE ' + D TMP-LINE + D ' COLUMN ' + D TMP-COLUMN + D UPON SYSERR. + + 2000-EXIT. EXIT. + + 3000-LIST-WINDOWS. + + SET WL-INDEX TO +1. + D DISPLAY ' =========> START LISTING WINDOWS ' UPON SYSERR. + PERFORM 20 TIMES + IF WL-WINDOW (WL-INDEX) EQUAL LOW-VALUES + EXIT PERFORM + END-IF + D DISPLAY ' DEPTH => ' WL-DEPTH (WL-INDEX) + D ' NUMBER => ' WL-WINDOW-NUMBER (WL-INDEX) + D ' POS ROW => ' WL-WINDOW-POSITION-ROW (WL-INDEX) + D ' POS COL => ' WL-WINDOW-POSITION-COL (WL-INDEX) + D ' WIN ROW => ' WL-WINDOW-SIZE-ROW (WL-INDEX) + D ' WIN COL => ' WL-WINDOW-SIZE-COL (WL-INDEX) + D ' FG => ' WL-WINDOW-FG-COLOR (WL-INDEX) + D ' BG => ' WL-WINDOW-BG-COLOR (WL-INDEX) + D ' HIDDEN => ' WL-WINDOW-HIDDEN (WL-INDEX) + D UPON SYSERR + SET WL-INDEX UP BY +1 + END-PERFORM. + D DISPLAY ' =========> END LISTING WINDOWS ' UPON SYSERR. + + 3000-EXIT. EXIT. + END PROGRAM SAMPLE. +]) + +AT_CHECK([$COMPILE prog.cob], [0], [], []) +MANUAL_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) + +AT_CLEANUP From 45ce8f622930f34306f64839dd397b9c4c4a0c00 Mon Sep 17 00:00:00 2001 From: sf-mensch Date: Tue, 19 Nov 2024 13:46:05 +0000 Subject: [PATCH 18/29] follow-up to r5369 - panel update * screenio.c (cob_sys_window), system.def, common.h: command as separate first argument * screenio.c [WITH_PANELS]: more refactoring including: * variable amount of elements for LIST command * parameter struture changes from int to short * new commands get+set attributes; * hidden now attribute in the flags instead of separate element, preparation for new attributes wrap + scroll * reverse panel_hidden return code handling * screenio.c (cob_exit_screen): always use stdscr for exit message --- libcob/ChangeLog | 15 +- libcob/common.h | 2 +- libcob/screenio.c | 535 ++++++++++++----------- libcob/system.def | 7 +- tests/run_prog_manual.sh.in | 2 +- tests/testsuite.src/run_manual_screen.at | 154 +++---- 6 files changed, 377 insertions(+), 338 deletions(-) diff --git a/libcob/ChangeLog b/libcob/ChangeLog index 7f6090b82..fe027fa16 100644 --- a/libcob/ChangeLog +++ b/libcob/ChangeLog @@ -1,7 +1,20 @@ -2024-10-04 Simon Sobisch +2024-11-19 Simon Sobisch + + * screenio.c (cob_sys_window), system.def, common.h: + command as separate first argument + * screenio.c [WITH_PANELS]: more refactoring including: + variable amount of elements for LIST command; + parameter struture changes from int to short; + new commands get+set attributes; + hidden now attribute in the flags instead of separate element, + preparation for new attributes wrap + scroll; + reverse panel_hidden return code handling + * screenio.c (cob_exit_screen): always use stdscr for exit message + +2024-11-18 Simon Sobisch * screenio.c [WITH_PANELS]: minor refactoring including move of return code out of PPARM_FLD diff --git a/libcob/common.h b/libcob/common.h index 67f7ffeb8..18512d7a0 100644 --- a/libcob/common.h +++ b/libcob/common.h @@ -2182,7 +2182,7 @@ COB_EXPIMP int cob_sys_get_scr_size (unsigned char *, unsigned char *); COB_EXPIMP int cob_sys_set_scr_size (unsigned char *, unsigned char *); COB_EXPIMP int cob_sys_scr_dump (unsigned char *); COB_EXPIMP int cob_sys_scr_restore (unsigned char *); -COB_EXPIMP int cob_sys_window (unsigned char *); +COB_EXPIMP int cob_sys_window (unsigned char*, unsigned char *); COB_EXPIMP int cob_sys_get_char (unsigned char *); COB_EXPIMP int cob_get_text (char *, int); COB_EXPIMP int cob_get_scr_cols (void); diff --git a/libcob/screenio.c b/libcob/screenio.c index 30d744db5..0ce956a87 100644 --- a/libcob/screenio.c +++ b/libcob/screenio.c @@ -195,26 +195,34 @@ static WINDOW *mywin; #ifdef WITH_PANELS #define MAX_PANELS 20 -#define CBL_NEW_WINDOW 1 -#define CBL_DELETE_WINDOW 2 -#define CBL_MOVE_WINDOW 3 -#define CBL_SHOW_WINDOW 4 -#define CBL_HIDE_WINDOW 5 -#define CBL_TOP_WINDOW 6 -#define CBL_BOTTOM_WINDOW 7 -#define CBL_LIST_WINDOW 8 + +enum sys_win_mode { + SYS_WIN_NEW = 'N', + SYS_WIN_DELETE = 'D', + SYS_WIN_ATTR_GET = 'G', + SYS_WIN_ATTR_CHANGE = 'S', + SYS_WIN_MOVE = 'M', + SYS_WIN_SHOW = 'V', + SYS_WIN_HIDE = 'I', + SYS_WIN_TOP = 'T', + SYS_WIN_BOTTOM = 'B', + SYS_WIN_LIST = 'L' +}; + +#define SYS_WIN_FLAG_HIDDEN (1 << 0) +#define SYS_WIN_FLAG_NOSCROLL (1 << 1) +#define SYS_WIN_FLAG_NOWRAP (1 << 2) typedef struct __PARM_FLD { - int mode; - int pan_number; - int starty; - int startx; - int win_rows; - int win_cols; - int fg_color; - int bg_color; - int hidden; + short pan_number; + short starty; + short startx; + short win_lines; + short win_cols; + short fg_color; + short bg_color; + short flags; } PARM_FLD, *PPARM_FLD; typedef struct __LIST_FLD @@ -223,27 +231,27 @@ typedef struct __LIST_FLD short pan_number; short starty; short startx; - short win_rows; + short win_lines; short win_cols; short input_fg_color; short input_bg_color; - short hidden; + short flags; } LIST_FLD, *PLIST_FLD; typedef struct __PANEL_ENTRY { PANEL *pan; WINDOW *win; - int starty; - int startx; - int win_rows; - int win_cols; - int hidden; + short starty; + short startx; + short win_lines; + short win_cols; + short flags; short fg_color; short bg_color; - int input_fg_color; - int input_bg_color; - int pan_number; + short input_fg_color; + short input_bg_color; + short pan_number; } PANEL_ENTRY, *PPANEL_ENTRY; static PANEL_ENTRY my_panels[MAX_PANELS] = @@ -4656,8 +4664,12 @@ cob_exit_screen (void) } if (cobglobptr->cob_screen_initialized) { if (pending_accept && cobsetptr->cob_exit_wait) { - /* FIXME: we likely should position to the last line since last cleanup before: - DISPLAY AT 1010 DISPLAY AT 0909 GOBACK overrides first DISPLAY */ + /* FIXME: we likely should position to either the very last line or + the last line since last cleanup + 1 before; problem: + DISPLAY AT 1010 DISPLAY AT 0909 GOBACK + results in first DISPLAY to be overwritten */ + WINDOW *savwin = mywin; + mywin = stdscr; /* consider also to restore fg+bg coilor + use reverse-video */ if (cobsetptr->cob_exit_msg[0] != 0) { snprintf (exit_msg, COB_MINI_BUFF, "\n%s ", cobsetptr->cob_exit_msg); cob_display_text (exit_msg); @@ -4671,6 +4683,7 @@ cob_exit_screen (void) cob_settings_screenio (); } field_accept_from_curpos (NULL, NULL, NULL, NULL, NULL, NULL, NULL, flags); + mywin = savwin; } cobglobptr->cob_screen_initialized = 0; #if 0 /* CHECKME: Shouldn't be necessary */ @@ -5269,66 +5282,6 @@ cob_init_screenio (cob_global *lptr, cob_settings *sptr) cob_settings_screenio (); } -/* Check the parms used for the panel functions */ -static int -check_panel_parm (PPARM_FLD parm) -{ - switch (parm->mode) { - case CBL_NEW_WINDOW: - if (parm->starty > COB_MAX_Y_COORD) - return 2; - if (parm->startx > COB_MAX_X_COORD) - return 4; - if (parm->win_rows > COB_MAX_Y_COORD) - return 6; - if (parm->win_cols > COB_MAX_X_COORD) - return 7; - if (parm->bg_color < 0 || parm->bg_color > 15) - return 8; - if (parm->fg_color < 0 || parm->fg_color > 15) - return 9; - if (parm->fg_color == parm->bg_color) - return 11; - break; - case CBL_DELETE_WINDOW: - if (parm->pan_number < 1 || parm->pan_number > MAX_PANELS) - return 10; - break; - case CBL_MOVE_WINDOW: - if (parm->starty > COB_MAX_Y_COORD) - return 2; - if (parm->startx > COB_MAX_X_COORD) - return 4; - if (parm->pan_number < 1 || parm->pan_number > MAX_PANELS) - return 10; - break; - case CBL_HIDE_WINDOW: - if (parm->pan_number < 1 || parm->pan_number > MAX_PANELS) - return 10; - if (parm->hidden != 1 ) - return 12; - break; - case CBL_SHOW_WINDOW: - if (parm->pan_number < 1 || parm->pan_number > MAX_PANELS) - return 10; - if (parm->hidden != 0 ) - return 14; - break; - case CBL_TOP_WINDOW: - if (parm->pan_number < 1 || parm->pan_number > MAX_PANELS) - return 16; - break; - case CBL_BOTTOM_WINDOW: - if (parm->pan_number < 1 || parm->pan_number > MAX_PANELS) - return 18; - break; - default: - return 99; - } - - return 0; -} - /* These functions are only defined if we have PANELS */ #ifdef WITH_PANELS @@ -5336,7 +5289,7 @@ check_panel_parm (PPARM_FLD parm) /* this function updates all the windows which are not hidden and then does the final "doupdate" to update the physical screen */ static void -cob_update_all_windows (void) +update_all_windows (void) { /* first get the top panel */ PANEL *ptr_pan = ceiling_panel (NULL); @@ -5362,7 +5315,7 @@ cob_update_all_windows (void) /* NEW_WINDOW - create a new panel / window pair */ static int -cob_new_window (PPARM_FLD parm) +sys_window_new (PPARM_FLD parm) { PPANEL_ENTRY pan_first = &my_panels[0]; PPANEL_ENTRY pan_last = &my_panels[MAX_PANELS]; @@ -5373,11 +5326,9 @@ cob_new_window (PPARM_FLD parm) short bg_color; short color_pr; - init_cob_screen_if_needed (); - /* find empty slot in panel array */ - for(ptr_pan_entry = pan_first; ptr_pan_entry <= pan_last; ptr_pan_entry++) { + for (ptr_pan_entry = pan_first; ptr_pan_entry <= pan_last; ptr_pan_entry++) { if (ptr_pan_entry->pan == NULL) break; } @@ -5388,15 +5339,22 @@ cob_new_window (PPARM_FLD parm) return 20; } - ptr_win = newwin(parm->win_rows, + /* note: takes all available space if lines/cols are zero */ + ptr_win = newwin (parm->win_lines, parm->win_cols, parm->starty - 1, parm->startx - 1); if (!ptr_win) { return 22; } + + #if 0 /* CHECKME, possibly doing manually ?!?e */ + scrollok (ptr_win, (parm->flags & SYS_WIN_FLAG_NOSCROLL)); + (parm->flags & SYS_WIN_FLAG_NOWRAP); /* TODO */ + #endif - ptr_pan = new_panel(ptr_win); + + ptr_pan = new_panel (ptr_win); if (!ptr_pan) { return 24; } @@ -5407,11 +5365,11 @@ cob_new_window (PPARM_FLD parm) parm->pan_number = ptr_pan_entry->pan_number; ptr_pan_entry->pan = ptr_pan; ptr_pan_entry->win = ptr_win; - ptr_pan_entry->win_rows = parm->win_rows; + ptr_pan_entry->win_lines = parm->win_lines; ptr_pan_entry->win_cols = parm->win_cols; ptr_pan_entry->startx = parm->startx - 1; ptr_pan_entry->starty = parm->starty - 1; - ptr_pan_entry->hidden = 0; + ptr_pan_entry->flags = parm->flags; if (set_panel_userptr (ptr_pan, ptr_pan_entry)) { return 26; @@ -5429,30 +5387,30 @@ cob_new_window (PPARM_FLD parm) ptr_pan_entry->input_bg_color = parm->bg_color; color_pr = cob_get_color_pair (fg_color, bg_color); wbkgd (mywin ,COLOR_PAIR (color_pr)); - werase(mywin); + werase (mywin); fore_color = fg_color; back_color = bg_color; - cob_update_all_windows (); + update_all_windows (); return 0; } /* MOVE_WINDOW - move the panel within stdscr */ static int -cob_move_window (PPARM_FLD parm) +sys_window_move (PPARM_FLD parm) { - PPANEL_ENTRY ptr_pan_entry; - PANEL *ptr_pan; + PPANEL_ENTRY ptr_pan_entry = &my_panels[parm->pan_number - 1]; + PANEL *ptr_pan = ptr_pan_entry->pan; - init_cob_screen_if_needed (); - - ptr_pan_entry = &my_panels[parm->pan_number - 1]; - if (!ptr_pan_entry->pan) { + if (!ptr_pan) { return 28; } - ptr_pan = ptr_pan_entry->pan; - - if (!panel_hidden(ptr_pan_entry->pan)) { + if (panel_hidden (ptr_pan)) { + /* TODO: it should be possible to move a hidden + panel as well (if there's a curses issue: either unhide, move, hide + or add a "pending change" flag, set the internal vars only and on + unhide wioth the flag set do all the adjustments then - possibly + by calling this function from there) */ return 40; } @@ -5463,103 +5421,106 @@ cob_move_window (PPARM_FLD parm) ptr_pan_entry->startx = parm->startx - 1; ptr_pan_entry->starty = parm->starty - 1; - ptr_pan = ceiling_panel(NULL); + /* CHECKME: why do we use the top panel here, when we moved + another panel before ?!? */ + ptr_pan = ceiling_panel (NULL); + mywin = panel_window (ptr_pan); - ptr_pan_entry = (PPANEL_ENTRY)panel_userptr(ptr_pan); - fore_color = ptr_pan_entry->fg_color; - back_color = ptr_pan_entry->bg_color; +#if 0 /* to be tested */ + /* TODO: if lines and/or cols are zero, should take all available space, + needs to calculate this up-front */ + wresize (mywin, parm->win_lines, parm->win_cols); +#endif + ptr_pan_entry = (PPANEL_ENTRY)panel_userptr (ptr_pan); - parm->win_rows = ptr_pan_entry->win_rows; + parm->win_lines = ptr_pan_entry->win_lines; parm->win_cols = ptr_pan_entry->win_cols; parm->startx = ptr_pan_entry->startx + 1; parm->starty = ptr_pan_entry->starty + 1; - parm->hidden = ptr_pan_entry->hidden; + parm->flags = ptr_pan_entry->flags; parm->fg_color = ptr_pan_entry->input_fg_color; parm->bg_color = ptr_pan_entry->input_bg_color; - cob_update_all_windows (); + fore_color = ptr_pan_entry->fg_color; + back_color = ptr_pan_entry->bg_color; + + update_all_windows (); return 0; } /* SHOW_WINDOW - show the panel within stdscr */ static int -cob_show_window (PPARM_FLD parm) +sys_window_show (PPARM_FLD parm) { - PPANEL_ENTRY ptr_pan_entry; - PANEL *ptr_pan; + PPANEL_ENTRY ptr_pan_entry = &my_panels[parm->pan_number - 1]; + PANEL *ptr_pan = ptr_pan_entry->pan; - init_cob_screen_if_needed (); - - ptr_pan_entry = &my_panels[parm->pan_number - 1]; - if (!ptr_pan_entry->pan) { + if (!ptr_pan) { return 28; } - if (panel_hidden(ptr_pan_entry->pan)) { + if (!panel_hidden (ptr_pan)) { + /* CHECKME: is there a reason to not just update internal vars + and exit with zero? */ return 42; } - ptr_pan = ptr_pan_entry->pan; - - if (show_panel(ptr_pan)) { + if (show_panel (ptr_pan)) { return 30; } - ptr_pan_entry->hidden = 0; + ptr_pan_entry->flags = ~SYS_WIN_FLAG_HIDDEN; - ptr_pan = ceiling_panel(NULL); + ptr_pan = ceiling_panel (NULL); mywin = panel_window (ptr_pan); - ptr_pan_entry = (PPANEL_ENTRY)panel_userptr(ptr_pan); + ptr_pan_entry = (PPANEL_ENTRY)panel_userptr (ptr_pan); fore_color = ptr_pan_entry->fg_color; back_color = ptr_pan_entry->bg_color; - parm->win_rows = ptr_pan_entry->win_rows; + parm->win_lines = ptr_pan_entry->win_lines; parm->win_cols = ptr_pan_entry->win_cols; parm->startx = ptr_pan_entry->startx + 1; parm->starty = ptr_pan_entry->starty + 1; - parm->hidden = ptr_pan_entry->hidden; + parm->flags = ptr_pan_entry->flags; parm->fg_color = ptr_pan_entry->input_fg_color; parm->bg_color = ptr_pan_entry->input_bg_color; - cob_update_all_windows (); + update_all_windows (); return 0; } /* HIDE_WINDOW - hide the panel within stdscr */ static int -cob_hide_window (PPARM_FLD parm) +sys_window_hide (PPARM_FLD parm) { - PPANEL_ENTRY ptr_pan_entry; - PANEL *ptr_pan; + PPANEL_ENTRY ptr_pan_entry = &my_panels[parm->pan_number - 1]; + PANEL *ptr_pan = ptr_pan_entry->pan; - init_cob_screen_if_needed (); - - ptr_pan_entry = &my_panels[parm->pan_number - 1]; - if (!ptr_pan_entry->pan) { + if (!ptr_pan) { return 28; } - ptr_pan = ptr_pan_entry->pan; - - if (!panel_hidden(ptr_pan_entry->pan)) { + if (panel_hidden (ptr_pan)) { + /* CHECKME: is there a reason to not just update internal vars + and exit with zero? */ return 40; } - if (hide_panel(ptr_pan)) { + if (hide_panel (ptr_pan)) { return 32; } - ptr_pan_entry->hidden = 1; + ptr_pan_entry->flags &= SYS_WIN_FLAG_HIDDEN; /* note the following is needed in case the top panel was hidden. then the next panel will be on top */ - ptr_pan = ceiling_panel(NULL); + ptr_pan = ceiling_panel (NULL); if (ptr_pan) { mywin = panel_window (ptr_pan); - ptr_pan_entry = (PPANEL_ENTRY)panel_userptr(ptr_pan); + ptr_pan_entry = (PPANEL_ENTRY)panel_userptr (ptr_pan); fore_color = ptr_pan_entry->fg_color; back_color = ptr_pan_entry->bg_color; } else { @@ -5569,124 +5530,111 @@ cob_hide_window (PPARM_FLD parm) back_color = stdscr_back_color; } - parm->win_rows = ptr_pan_entry->win_rows; + parm->win_lines = ptr_pan_entry->win_lines; parm->win_cols = ptr_pan_entry->win_cols; parm->startx = ptr_pan_entry->startx + 1; parm->starty = ptr_pan_entry->starty + 1; - parm->hidden = ptr_pan_entry->hidden; + parm->flags = ptr_pan_entry->flags; parm->fg_color = ptr_pan_entry->input_fg_color; parm->bg_color = ptr_pan_entry->input_bg_color; - cob_update_all_windows (); + update_all_windows (); return 0; } -/* TOP_WINDOW - top the panel within stdscr */ +/* TOP_WINDOW - make the panel top within stdscr */ static int -cob_top_window (PPARM_FLD parm) +sys_window_top (PPARM_FLD parm) { - PPANEL_ENTRY ptr_pan_entry; - PANEL *ptr_pan; + PPANEL_ENTRY ptr_pan_entry = &my_panels[parm->pan_number - 1]; + PANEL *ptr_pan = ptr_pan_entry->pan; - init_cob_screen_if_needed (); - - ptr_pan_entry = &my_panels[parm->pan_number - 1]; - if (!ptr_pan_entry->pan) { + if (!ptr_pan) { return 28; } - ptr_pan = ptr_pan_entry->pan; - - if (!panel_hidden(ptr_pan_entry->pan)) { + if (panel_hidden (ptr_pan)) { return 40; } - if (top_panel(ptr_pan)) { + if (top_panel (ptr_pan)) { return 34; } - ptr_pan = ceiling_panel(NULL); + ptr_pan = ceiling_panel (NULL); mywin = panel_window (ptr_pan); - ptr_pan_entry = (PPANEL_ENTRY)panel_userptr(ptr_pan); + ptr_pan_entry = (PPANEL_ENTRY)panel_userptr (ptr_pan); fore_color = ptr_pan_entry->fg_color; back_color = ptr_pan_entry->bg_color; - parm->win_rows = ptr_pan_entry->win_rows; + parm->win_lines = ptr_pan_entry->win_lines; parm->win_cols = ptr_pan_entry->win_cols; parm->startx = ptr_pan_entry->startx + 1; parm->starty = ptr_pan_entry->starty + 1; - parm->hidden = ptr_pan_entry->hidden; + parm->flags = ptr_pan_entry->flags; parm->fg_color = ptr_pan_entry->input_fg_color; parm->bg_color = ptr_pan_entry->input_bg_color; - cob_update_all_windows (); + update_all_windows (); return 0; } -/* BOTTOM_WINDOW - top the panel within stdscr */ +/* BOTTOM_WINDOW - make the panel bottem within stdscr */ static int -cob_bottom_window (PPARM_FLD parm) +sys_window_bottom (PPARM_FLD parm) { - PPANEL_ENTRY ptr_pan_entry; - PANEL *ptr_pan; + PPANEL_ENTRY ptr_pan_entry = &my_panels[parm->pan_number - 1]; + PANEL *ptr_pan = ptr_pan_entry->pan; - init_cob_screen_if_needed (); - - ptr_pan_entry = &my_panels[parm->pan_number - 1]; - if (!ptr_pan_entry->pan) { + if (!ptr_pan) { return 28; } - ptr_pan = ptr_pan_entry->pan; - - if (!panel_hidden(ptr_pan_entry->pan)) { + if (panel_hidden (ptr_pan)) { return 40; } - if (bottom_panel(ptr_pan)) { + if (bottom_panel (ptr_pan)) { return 35; } - ptr_pan = ceiling_panel(NULL); - ptr_pan_entry = (PPANEL_ENTRY)panel_userptr(ptr_pan); + ptr_pan = ceiling_panel (NULL); + ptr_pan_entry = (PPANEL_ENTRY)panel_userptr (ptr_pan); mywin = panel_window (ptr_pan); parm->pan_number = ptr_pan_entry->pan_number; fore_color = ptr_pan_entry->fg_color; back_color = ptr_pan_entry->bg_color; - parm->win_rows = ptr_pan_entry->win_rows; + parm->win_lines = ptr_pan_entry->win_lines; parm->win_cols = ptr_pan_entry->win_cols; parm->startx = ptr_pan_entry->startx + 1; parm->starty = ptr_pan_entry->starty + 1; - parm->hidden = ptr_pan_entry->hidden; + parm->flags = ptr_pan_entry->flags; parm->fg_color = ptr_pan_entry->input_fg_color; parm->bg_color = ptr_pan_entry->input_bg_color; - cob_update_all_windows (); + update_all_windows (); return 0; } /* DELETE_WINDOW - delete the panel within stdscr */ static int -cob_delete_window (PPARM_FLD parm) +sys_window_delete (PPARM_FLD parm) { - PPANEL_ENTRY ptr_pan_entry; - PANEL *ptr_pan; + PPANEL_ENTRY ptr_pan_entry = &my_panels[parm->pan_number - 1]; + PANEL *ptr_pan = ptr_pan_entry->pan; - init_cob_screen_if_needed (); - - ptr_pan_entry = &my_panels[parm->pan_number - 1]; - if (!ptr_pan_entry->pan) { + if (!ptr_pan) { return 28; } - if (!panel_hidden(ptr_pan_entry->pan)) { - show_panel( ptr_pan_entry->pan); + if (panel_hidden (ptr_pan)) { + show_panel (ptr_pan); } - if (del_panel (ptr_pan_entry->pan)) { + if (del_panel (ptr_pan)) { return 38; } @@ -5696,21 +5644,21 @@ cob_delete_window (PPARM_FLD parm) ptr_pan_entry->pan = NULL; ptr_pan_entry->win = NULL; - ptr_pan_entry->win_rows = 0; + ptr_pan_entry->win_lines = 0; ptr_pan_entry->win_cols = 0; ptr_pan_entry->startx = 0; ptr_pan_entry->starty = 0; - ptr_pan_entry->hidden = 0; + ptr_pan_entry->flags = 0; ptr_pan_entry->fg_color = 0; ptr_pan_entry->bg_color = 7; ptr_pan_entry->input_fg_color = 0; ptr_pan_entry->input_bg_color = 7; - ptr_pan = ceiling_panel(NULL); + ptr_pan = ceiling_panel (NULL); if (ptr_pan) { mywin = panel_window (ptr_pan); - ptr_pan_entry = (PPANEL_ENTRY)panel_userptr(ptr_pan); + ptr_pan_entry = (PPANEL_ENTRY)panel_userptr (ptr_pan); fore_color = ptr_pan_entry->fg_color; back_color = ptr_pan_entry->bg_color; } else { @@ -5720,63 +5668,70 @@ cob_delete_window (PPARM_FLD parm) back_color = stdscr_back_color; } - parm->win_rows = ptr_pan_entry->win_rows; + parm->win_lines = ptr_pan_entry->win_lines; parm->win_cols = ptr_pan_entry->win_cols; parm->startx = ptr_pan_entry->startx + 1; parm->starty = ptr_pan_entry->starty + 1; - parm->hidden = ptr_pan_entry->hidden; + parm->flags = ptr_pan_entry->flags; parm->fg_color = ptr_pan_entry->input_fg_color; parm->bg_color = ptr_pan_entry->input_bg_color; - cob_update_all_windows (); + update_all_windows (); return 0; } /* LIST_WINDOW - list all of the windows */ -static int -cob_list_window (PLIST_FLD list) +static void +sys_window_list (PLIST_FLD list, size_t amount) { PPANEL_ENTRY ptr_pan_entry; PANEL *ptr_pan; int depth, loop; depth = 1; - memset(list, 0, MAX_PANELS * sizeof(LIST_FLD)); - ptr_pan = ceiling_panel(NULL); + memset (list, 0, amount * sizeof(LIST_FLD)); - while (ptr_pan) { - ptr_pan_entry = (PPANEL_ENTRY)panel_userptr(ptr_pan); + if (amount > MAX_PANELS) { + amount = MAX_PANELS; + } + + /* find the depth of all the active windows, + starting at ceiling (top of deck) and work down... */ + ptr_pan = ceiling_panel (NULL); + while (ptr_pan && depth <= amount) { + ptr_pan_entry = (PPANEL_ENTRY)panel_userptr (ptr_pan); list->pan_position = depth; list->pan_number = ptr_pan_entry->pan_number; - list->win_rows = ptr_pan_entry->win_rows; + list->win_lines = ptr_pan_entry->win_lines; list->win_cols = ptr_pan_entry->win_cols; list->startx = ptr_pan_entry->startx + 1; list->starty = ptr_pan_entry->starty + 1; - list->hidden = ptr_pan_entry->hidden; + list->flags = ptr_pan_entry->flags; list->input_fg_color = ptr_pan_entry->input_fg_color; list->input_bg_color = ptr_pan_entry->input_bg_color; list++; depth++; ptr_pan = panel_below (ptr_pan); } - ptr_pan_entry = &my_panels[0]; - for(loop = 0; loop < MAX_PANELS; loop++, ptr_pan_entry++) { - if (ptr_pan_entry->hidden) { + /* go through all of the hidden windows, + which are not in the panel deck but only in our internal list */ + ptr_pan_entry = &my_panels[0]; + for (loop = 0; loop < depth; loop++, ptr_pan_entry++) { + if (ptr_pan_entry->flags & SYS_WIN_FLAG_HIDDEN) { list->pan_position = 0; list->pan_number = ptr_pan_entry->pan_number; - list->win_rows = ptr_pan_entry->win_rows; + list->win_lines = ptr_pan_entry->win_lines; list->win_cols = ptr_pan_entry->win_cols; list->startx = ptr_pan_entry->startx + 1; list->starty = ptr_pan_entry->starty + 1; - list->hidden = ptr_pan_entry->hidden; + list->flags = ptr_pan_entry->flags; list->input_fg_color = ptr_pan_entry->input_fg_color; list->input_bg_color = ptr_pan_entry->input_bg_color; list++; } } - return 0; } #endif /* WITH_PANELS */ @@ -5784,47 +5739,131 @@ cob_list_window (PLIST_FLD list) /* CBL_GC_WINDOW - window functions */ int -cob_sys_window (unsigned char *fld) +cob_sys_window (unsigned char *mode_ext, unsigned char *fld) { #ifdef COB_EXPERIMENTAL - const cob_field *f1 = cob_get_param_field (1, "ANYPGM"); + const enum sys_win_mode mode = *mode_ext; + const cob_field *f2 = cob_get_param_field (2, "CBL_GC_WINDOW"); PPARM_FLD parm; - int ret; - COB_CHK_PARMS (CBL_GC_NEW_WINDOW, 1); - COB_UNUSED (fld); - init_cob_screen_if_needed (); + COB_CHK_PARMS (CBL_GC_NEW_WINDOW, 2); + if (!mode_ext || !fld) { + return -8; + } - if (f1->size == sizeof (PARM_FLD)) { - parm = (PPARM_FLD)f1->data; - ret = check_panel_parm (parm); - if (ret) { - return ret; - } - } else if (f1->size == MAX_PANELS * sizeof (LIST_FLD)) { + if (mode == SYS_WIN_LIST) { #ifdef WITH_PANELS - return (cob_list_window ((PLIST_FLD)f1->data)); + size_t amount = f2->size / sizeof (LIST_FLD); + if (!amount) return 44; + + init_cob_screen_if_needed (); + sys_window_list ((PLIST_FLD)f2->data, amount); + return 0; #endif + } else if (f2->size == sizeof (PARM_FLD)) { + parm = (PPARM_FLD)f2->data; + if ( mode != SYS_WIN_NEW + && (parm->pan_number < 1 || parm->pan_number > MAX_PANELS)) { + return 10; + } + + /* also needed for COB_MAX_X_COORD, so do early */ + init_cob_screen_if_needed (); + + switch (mode) { + case SYS_WIN_NEW: + case SYS_WIN_ATTR_CHANGE: + if (parm->starty > COB_MAX_Y_COORD) + return 2; + if (parm->startx > COB_MAX_X_COORD) + return 4; + if (parm->win_lines > COB_MAX_Y_COORD) + return 6; + if (parm->win_cols > COB_MAX_X_COORD) + return 7; + if (parm->bg_color < 0 || parm->bg_color > 15) + return 8; + if (parm->fg_color < 0 || parm->fg_color > 15) + return 9; + if (parm->fg_color == parm->bg_color) + return 11; + break; + case SYS_WIN_MOVE: + if (parm->starty > COB_MAX_Y_COORD) + return 2; + if (parm->startx > COB_MAX_X_COORD) + return 4; + break; + case SYS_WIN_ATTR_GET: + case SYS_WIN_DELETE: + case SYS_WIN_HIDE: + case SYS_WIN_SHOW: + case SYS_WIN_TOP: + case SYS_WIN_BOTTOM: + break; + default: + return 44; + } } else { return -8; } #ifdef WITH_PANELS - if (mywin == stdscr) { getyx (stdscr, save_cursor_y, save_cursor_x); stdscr_fore_color = fore_color; stdscr_back_color = back_color; } - switch (parm->mode) { - case CBL_NEW_WINDOW: return (cob_new_window (parm)); - case CBL_DELETE_WINDOW: return (cob_delete_window (parm)); - case CBL_MOVE_WINDOW: return (cob_move_window (parm)); - case CBL_HIDE_WINDOW: return (cob_hide_window (parm)); - case CBL_SHOW_WINDOW: return (cob_show_window (parm)); - case CBL_TOP_WINDOW: return (cob_top_window (parm)); - case CBL_BOTTOM_WINDOW: return (cob_bottom_window (parm)); + if (mode == SYS_WIN_ATTR_CHANGE) { + PPANEL_ENTRY ptr_pan_entry = &my_panels[parm->pan_number - 1]; + int ret = 0; + /* TODO: add changing colors */ + if (parm->win_lines != ptr_pan_entry->win_lines + || parm->win_cols != ptr_pan_entry->win_cols + || parm->startx != ptr_pan_entry->startx + 1 + || parm->starty != ptr_pan_entry->starty + 1) { + /* TODO: ensure that resizing works */ + ret += sys_window_move (parm); + } + if (ptr_pan_entry->flags != parm->flags) { + if ((ptr_pan_entry->flags & SYS_WIN_FLAG_HIDDEN) != (parm->flags & SYS_WIN_FLAG_HIDDEN)) { + if (parm->flags & SYS_WIN_FLAG_HIDDEN) { + ret += sys_window_hide (parm); + } else { + ret += sys_window_show (parm); + } + } + if ((ptr_pan_entry->flags & SYS_WIN_FLAG_NOSCROLL) != (parm->flags & SYS_WIN_FLAG_NOSCROLL)) { + /* TODO */ + } + if ((ptr_pan_entry->flags & SYS_WIN_FLAG_NOWRAP) != (parm->flags & SYS_WIN_FLAG_NOWRAP)) { + /* TODO */ + } + } + return ret; + } + if (mode == SYS_WIN_ATTR_GET) { + PPANEL_ENTRY ptr_pan_entry = &my_panels[parm->pan_number - 1]; + /* CHECKME: is this enough? */ + parm->win_lines = ptr_pan_entry->win_lines; + parm->win_cols = ptr_pan_entry->win_cols; + parm->startx = ptr_pan_entry->startx + 1; + parm->starty = ptr_pan_entry->starty + 1; + parm->flags = ptr_pan_entry->flags; + parm->fg_color = ptr_pan_entry->input_fg_color; + parm->bg_color = ptr_pan_entry->input_bg_color; + return 0; + } + + switch (mode) { + case SYS_WIN_NEW: return (sys_window_new (parm)); + case SYS_WIN_DELETE: return (sys_window_delete (parm)); + case SYS_WIN_MOVE: return (sys_window_move (parm)); + case SYS_WIN_HIDE: return (sys_window_hide (parm)); + case SYS_WIN_SHOW: return (sys_window_show (parm)); + case SYS_WIN_TOP: return (sys_window_top (parm)); + case SYS_WIN_BOTTOM: return (sys_window_bottom (parm)); default: return 44; } @@ -5838,16 +5877,16 @@ cob_sys_window (unsigned char *fld) #else /* COB_EXPERIMENTAL */ + COB_UNUSED (mode_ext); COB_UNUSED (fld); - COB_UNUSED (check_panel_parm); - COB_UNUSED (cob_new_window); - COB_UNUSED (cob_delete_window); - COB_UNUSED (cob_move_window); - COB_UNUSED (cob_hide_window); - COB_UNUSED (cob_show_window); - COB_UNUSED (cob_top_window); - COB_UNUSED (cob_bottom_window); - COB_UNUSED (cob_list_window); + COB_UNUSED (sys_window_new); + COB_UNUSED (sys_window_delete); + COB_UNUSED (sys_window_move); + COB_UNUSED (sys_window_hide); + COB_UNUSED (sys_window_show); + COB_UNUSED (sys_window_top); + COB_UNUSED (sys_window_bottom); + COB_UNUSED (sys_window_list); if (getenv ("COB_IS_RUNNING_IN_TESTMODE")) { return 77; /* let testsuite skip related tests */ } diff --git a/libcob/system.def b/libcob/system.def index 29798ce31..75d8742b9 100644 --- a/libcob/system.def +++ b/libcob/system.def @@ -42,9 +42,6 @@ COB_SYSTEM_GEN ("CBL_FLUSH_FILE", 1, 1, cob_sys_flush_file) COB_SYSTEM_GEN ("CBL_GET_CSR_POS", 1, 1, cob_sys_get_csr_pos) COB_SYSTEM_GEN ("CBL_GET_CURRENT_DIR", 3, 3, cob_sys_get_current_dir) COB_SYSTEM_GEN ("CBL_GET_SCR_SIZE", 2, 2, cob_sys_get_scr_size) -COB_SYSTEM_GEN ("CBL_GC_SCR_DUMP", 1, 1, cob_sys_scr_dump) -COB_SYSTEM_GEN ("CBL_GC_SCR_RESTORE", 1, 1, cob_sys_scr_restore) -COB_SYSTEM_GEN ("CBL_GC_WINDOW", 1, 1, cob_sys_window) COB_SYSTEM_GEN ("CBL_IMP", 3, 3, cob_sys_imp) COB_SYSTEM_GEN ("CBL_NIMP", 3, 3, cob_sys_nimp) COB_SYSTEM_GEN ("CBL_NOR", 3, 3, cob_sys_nor) @@ -70,7 +67,9 @@ COB_SYSTEM_GEN ("CBL_GC_WAITPID", 1, 1, cob_sys_waitpid) COB_SYSTEM_GEN ("CBL_OC_GETOPT", 6, 6, cob_sys_getopt_long_long) COB_SYSTEM_GEN ("CBL_OC_HOSTED", 2, 2, cob_sys_hosted) COB_SYSTEM_GEN ("CBL_OC_NANOSLEEP", 1, 1, cob_sys_oc_nanosleep) - +COB_SYSTEM_GEN ("CBL_GC_SCR_DUMP", 1, 1, cob_sys_scr_dump) +COB_SYSTEM_GEN ("CBL_GC_SCR_RESTORE", 1, 1, cob_sys_scr_restore) +COB_SYSTEM_GEN ("CBL_GC_WINDOW", 2, 2, cob_sys_window) COB_SYSTEM_GEN ("C$CALLEDBY", 1, 1, cob_sys_calledby) COB_SYSTEM_GEN ("C$CHDIR", 2, 2, cob_sys_chdir) COB_SYSTEM_GEN ("C$COPY", 3, 3, cob_sys_copyfile) diff --git a/tests/run_prog_manual.sh.in b/tests/run_prog_manual.sh.in index dd063596e..73d78e6c5 100755 --- a/tests/run_prog_manual.sh.in +++ b/tests/run_prog_manual.sh.in @@ -69,7 +69,7 @@ TITLE="GnuCOBOL Manual Test Run - $DESC" _test_with_xterm () { xterm -T "$TITLE" \ -fa 'Liberation Mono' -fs 14 \ - -e "sh -c \"(\$* 2>./syserr.log && echo \$? > ./result) || echo 1 > ./result\"" + -e "sh -c \"($* 2>./syserr.log && echo \$? > ./result) || echo 1 > ./result\"" } diff --git a/tests/testsuite.src/run_manual_screen.at b/tests/testsuite.src/run_manual_screen.at index c4d30f0f9..94d5c5e1e 100644 --- a/tests/testsuite.src/run_manual_screen.at +++ b/tests/testsuite.src/run_manual_screen.at @@ -3816,32 +3816,25 @@ AT_CLEANUP AT_SETUP([system function CBL_GC_WINDOW]) -AT_KEYWORDS([screen]) +AT_KEYWORDS([screen extensions window]) AT_SKIP_IF([test "$COB_HAS_CURSES" != "yes"]) AT_DATA([prog.cob], [ -GNU >>SOURCE FORMAT IS FIXED -COBOL *> *************************************************************** - *> DATE: 20200630 - *> LICENSE: PUBLIC DOMAIN -COLORS*> PURPOSE: SHOW THE GNUCOBOL DEFAULT COLOUR PALETTE - *> TECTONICS: COBC -X GNUCOBOL-COLOURS.COB - *> *************************************************************** + >>SOURCE FORMAT IS FIXED IDENTIFICATION DIVISION. - PROGRAM-ID. SAMPLE. + PROGRAM-ID. prog. ENVIRONMENT DIVISION. CONFIGURATION SECTION. *SOURCE-COMPUTER. IBM-PC WITH DEBUGGING MODE. OBJECT-COMPUTER. IBM-PC. - REPOSITORY. - FUNCTION ALL INTRINSIC. - DATA DIVISION. WORKING-STORAGE SECTION. + *> TODO: if possible drop colors all together from this test or use + *> reverse-video; if not replace with screenio.cpy 01 BLACK CONSTANT AS 0. 01 BLUE CONSTANT AS 1. 01 GREEN CONSTANT AS 2. @@ -3854,19 +3847,19 @@ COLORS*> PURPOSE: SHOW THE GNUCOBOL DEFAULT COLOUR PALETTE 77 ANSWER-TEXT PIC X. 01 SW-EVEN PIC X VALUE 'N'. - 01 CNTR PIC S9(9) COMP-5 VALUE +0. - 01 CNTR-ROW PIC S9(9) COMP-5 VALUE +0. - 01 CNTR-COL PIC S9(9) COMP-5 VALUE +0. + 01 CNTR USAGE BINARY-SHORT VALUE +0. + 01 CNTR-LINE USAGE BINARY-SHORT VALUE +0. + 01 CNTR-COL USAGE BINARY-SHORT VALUE +0. 01 CURSOR-LOCN-BUFFER. - 05 CURSOR-LINE USAGE BINARY-CHAR UNSIGNED. - 05 CURSOR-COLUMN USAGE BINARY-CHAR UNSIGNED. + 05 CURSOR-LINE USAGE BINARY-CHAR UNSIGNED. + 05 CURSOR-COLUMN USAGE BINARY-CHAR UNSIGNED. - 01 TMP. - 05 TMP-LINE PIC 9(4) COMP-5. - 05 TMP-COLUMN PIC 9(4) COMP-5. + D01 TMP. + D 05 TMP-LINE PIC 9(4) COMP-5. + D 05 TMP-COLUMN PIC 9(4) COMP-5. - COPY 'gcwindow'. + COPY 'gcwindow'. SCREEN SECTION. 01 GNUCOBOL-COLOURS. @@ -3962,9 +3955,9 @@ COLORS*> PURPOSE: SHOW THE GNUCOBOL DEFAULT COLOUR PALETTE PERFORM 4 TIMES ADD +5 TO CNTR - MOVE CNTR TO WP-WINDOW-START-ROW + MOVE CNTR TO WP-WINDOW-START-LINE MOVE CNTR TO WP-WINDOW-START-COL - MOVE 20 TO WP-WINDOW-ROWS + MOVE 20 TO WP-WINDOW-LINES MOVE 60 TO WP-WINDOW-COLUMNS IF SW-EVEN EQUAL 'Y' MOVE 'N' TO SW-EVEN @@ -3975,14 +3968,14 @@ COLORS*> PURPOSE: SHOW THE GNUCOBOL DEFAULT COLOUR PALETTE MOVE 0 TO WP-WINDOW-FG-COLOR MOVE 3 TO WP-WINDOW-BG-COLOR END-IF - MOVE ZERO TO WP-WINDOW-HIDDEN - SET WP-MODE-NEW-WINDOW TO TRUE - PERFORM 1000-WINDOW-FUNCTION THRU 1000-EXIT - CALL 'CBL_GC_WINDOW' USING WL-WINDOW-LIST - PERFORM 3000-LIST-WINDOWS THRU 3000-EXIT - PERFORM 2000-WINDOW-CSR-POS THRU 2000-EXIT + MOVE ZERO TO WP-WINDOW-FLAGS + SET WP-MODE-NEW TO TRUE + PERFORM 1000-WINDOW-FUNCTION + CALL 'CBL_GC_WINDOW' USING WP-WINDOW-LIST WL-WINDOW-LIST + PERFORM 3000-LIST-WINDOWS + PERFORM 2000-WINDOW-CSR-POS DISPLAY GNUCOBOL-COLOURS - PERFORM 2000-WINDOW-CSR-POS THRU 2000-EXIT + PERFORM 2000-WINDOW-CSR-POS CALL "C$SLEEP" USING 1 END-PERFORM. @@ -3996,11 +3989,11 @@ COLORS*> PURPOSE: SHOW THE GNUCOBOL DEFAULT COLOUR PALETTE PERFORM 4 TIMES ADD +1 TO CNTR MOVE CNTR TO WP-WINDOW-NUMBER - MOVE 1 TO WP-WINDOW-HIDDEN - SET WP-MODE-HIDE-WINDOW TO TRUE - PERFORM 1000-WINDOW-FUNCTION THRU 1000-EXIT - CALL 'CBL_GC_WINDOW' USING WL-WINDOW-LIST - PERFORM 3000-LIST-WINDOWS THRU 3000-EXIT + MOVE WP-FLAG-HIDDEN TO WP-WINDOW-FLAGS + SET WP-MODE-HIDE TO TRUE + PERFORM 1000-WINDOW-FUNCTION + CALL 'CBL_GC_WINDOW' USING WP-WINDOW-LIST WL-WINDOW-LIST + PERFORM 3000-LIST-WINDOWS CALL "C$SLEEP" USING 1 END-PERFORM. @@ -4014,18 +4007,18 @@ COLORS*> PURPOSE: SHOW THE GNUCOBOL DEFAULT COLOUR PALETTE PERFORM 4 TIMES ADD -1 TO CNTR MOVE CNTR TO WP-WINDOW-NUMBER - MOVE ZERO TO WP-WINDOW-HIDDEN - SET WP-MODE-SHOW-WINDOW TO TRUE - PERFORM 1000-WINDOW-FUNCTION THRU 1000-EXIT - CALL 'CBL_GC_WINDOW' USING WL-WINDOW-LIST - PERFORM 3000-LIST-WINDOWS THRU 3000-EXIT + MOVE ZERO TO WP-WINDOW-FLAGS + SET WP-MODE-SHOW TO TRUE + PERFORM 1000-WINDOW-FUNCTION + CALL 'CBL_GC_WINDOW' USING WP-WINDOW-LIST WL-WINDOW-LIST + PERFORM 3000-LIST-WINDOWS CALL "C$SLEEP" USING 1 - PERFORM 2000-WINDOW-CSR-POS THRU 2000-EXIT + PERFORM 2000-WINDOW-CSR-POS END-PERFORM. MOVE ZERO TO CNTR. MOVE 10 TO CNTR-COL. - MOVE 10 TO CNTR-ROW. + MOVE 10 TO CNTR-LINE. D DISPLAY ' ' UPON SYSERR D DISPLAY ' STARTING MOVE WINDOWS ' UPON SYSERR @@ -4033,26 +4026,26 @@ COLORS*> PURPOSE: SHOW THE GNUCOBOL DEFAULT COLOUR PALETTE D DISPLAY ' ' UPON SYSERR PERFORM 4 TIMES - PERFORM 2000-WINDOW-CSR-POS THRU 2000-EXIT + PERFORM 2000-WINDOW-CSR-POS ADD +1 TO CNTR - ADD +2 TO CNTR-ROW + ADD +2 TO CNTR-LINE ADD +2 TO CNTR-COL MOVE CNTR TO WP-WINDOW-NUMBER - MOVE CNTR-ROW TO WP-WINDOW-START-ROW + MOVE CNTR-LINE TO WP-WINDOW-START-LINE MOVE CNTR-COL TO WP-WINDOW-START-COL - MOVE 0 TO WP-WINDOW-HIDDEN - SET WP-MODE-MOVE-WINDOW TO TRUE - PERFORM 1000-WINDOW-FUNCTION THRU 1000-EXIT - CALL 'CBL_GC_WINDOW' USING WL-WINDOW-LIST - PERFORM 3000-LIST-WINDOWS THRU 3000-EXIT + MOVE 0 TO WP-WINDOW-FLAGS + SET WP-MODE-MOVE TO TRUE + PERFORM 1000-WINDOW-FUNCTION + CALL 'CBL_GC_WINDOW' USING WP-WINDOW-LIST WL-WINDOW-LIST + PERFORM 3000-LIST-WINDOWS MOVE CNTR TO WP-WINDOW-NUMBER - MOVE 0 TO WP-WINDOW-START-ROW + MOVE 0 TO WP-WINDOW-START-LINE MOVE 0 TO WP-WINDOW-START-COL - MOVE 0 TO WP-WINDOW-HIDDEN - PERFORM 2000-WINDOW-CSR-POS THRU 2000-EXIT - SET WP-MODE-TOP-WINDOW TO TRUE - PERFORM 1000-WINDOW-FUNCTION THRU 1000-EXIT - PERFORM 2000-WINDOW-CSR-POS THRU 2000-EXIT + MOVE 0 TO WP-WINDOW-FLAGS + PERFORM 2000-WINDOW-CSR-POS + SET WP-MODE-TOP TO TRUE + PERFORM 1000-WINDOW-FUNCTION + PERFORM 2000-WINDOW-CSR-POS CALL "C$SLEEP" USING 1 END-PERFORM. @@ -4071,11 +4064,11 @@ COLORS*> PURPOSE: SHOW THE GNUCOBOL DEFAULT COLOUR PALETTE PERFORM 4 TIMES ADD +1 TO CNTR MOVE CNTR TO WP-WINDOW-NUMBER - MOVE 1 TO WP-WINDOW-HIDDEN - SET WP-MODE-BOTTOM-WINDOW TO TRUE - PERFORM 1000-WINDOW-FUNCTION THRU 1000-EXIT - CALL 'CBL_GC_WINDOW' USING WL-WINDOW-LIST - PERFORM 3000-LIST-WINDOWS THRU 3000-EXIT + MOVE WP-FLAG-HIDDEN TO WP-WINDOW-FLAGS + SET WP-MODE-BOTTOM TO TRUE + PERFORM 1000-WINDOW-FUNCTION + CALL 'CBL_GC_WINDOW' USING WP-WINDOW-LIST WL-WINDOW-LIST + PERFORM 3000-LIST-WINDOWS * CALL "C$SLEEP" USING 1 END-PERFORM. @@ -4088,11 +4081,11 @@ COLORS*> PURPOSE: SHOW THE GNUCOBOL DEFAULT COLOUR PALETTE PERFORM 4 TIMES ADD +1 TO CNTR MOVE CNTR TO WP-WINDOW-NUMBER - MOVE 1 TO WP-WINDOW-HIDDEN - SET WP-MODE-DELETE-WINDOW TO TRUE - PERFORM 1000-WINDOW-FUNCTION THRU 1000-EXIT - CALL 'CBL_GC_WINDOW' USING WL-WINDOW-LIST - PERFORM 3000-LIST-WINDOWS THRU 3000-EXIT + MOVE WP-FLAG-HIDDEN TO WP-WINDOW-FLAGS + SET WP-MODE-DELETE TO TRUE + PERFORM 1000-WINDOW-FUNCTION + CALL 'CBL_GC_WINDOW' USING WP-WINDOW-LIST WL-WINDOW-LIST + PERFORM 3000-LIST-WINDOWS * CALL "C$SLEEP" USING 1 END-PERFORM. @@ -4114,21 +4107,19 @@ COLORS*> PURPOSE: SHOW THE GNUCOBOL DEFAULT COLOUR PALETTE 1000-WINDOW-FUNCTION. - CALL 'CBL_GC_WINDOW' USING WP-WINDOW-PARMS. - IF RETURN-CODE NOT EQUAL ZERO - D DISPLAY 'RETURN CODE IS ==> ' RETURN-CODE - D UPON SYSERR - GOBACK - END-IF. - + CALL 'CBL_GC_WINDOW' USING WP-WINDOW-MODE WP-WINDOW-PARMS. + IF RETURN-CODE NOT EQUAL ZERO + D DISPLAY 'RETURN CODE IS ==> ' RETURN-CODE + D UPON SYSERR + GOBACK + END-IF. - 1000-EXIT. EXIT. 2000-WINDOW-CSR-POS. CALL "CBL_GET_CSR_POS" USING CURSOR-LOCN-BUFFER. - COMPUTE TMP-LINE = CURSOR-LINE + 1. - COMPUTE TMP-COLUMN = CURSOR-COLUMN + 1. + D COMPUTE TMP-LINE = CURSOR-LINE + 1. + D COMPUTE TMP-COLUMN = CURSOR-COLUMN + 1. D DISPLAY ' WINDOW ==> ' WP-WINDOW-NUMBER D ' CURSOR POSITION IS LINE ' D TMP-LINE @@ -4136,7 +4127,6 @@ COLORS*> PURPOSE: SHOW THE GNUCOBOL DEFAULT COLOUR PALETTE D TMP-COLUMN D UPON SYSERR. - 2000-EXIT. EXIT. 3000-LIST-WINDOWS. @@ -4148,20 +4138,18 @@ COLORS*> PURPOSE: SHOW THE GNUCOBOL DEFAULT COLOUR PALETTE END-IF D DISPLAY ' DEPTH => ' WL-DEPTH (WL-INDEX) D ' NUMBER => ' WL-WINDOW-NUMBER (WL-INDEX) - D ' POS ROW => ' WL-WINDOW-POSITION-ROW (WL-INDEX) + D ' POS ROW => ' WL-WINDOW-POSITION-LINE (WL-INDEX) D ' POS COL => ' WL-WINDOW-POSITION-COL (WL-INDEX) - D ' WIN ROW => ' WL-WINDOW-SIZE-ROW (WL-INDEX) - D ' WIN COL => ' WL-WINDOW-SIZE-COL (WL-INDEX) + D ' WIN ROW => ' WL-WINDOW-SIZE-LINES (WL-INDEX) + D ' WIN COL => ' WL-WINDOW-SIZE-COLS (WL-INDEX) D ' FG => ' WL-WINDOW-FG-COLOR (WL-INDEX) D ' BG => ' WL-WINDOW-BG-COLOR (WL-INDEX) - D ' HIDDEN => ' WL-WINDOW-HIDDEN (WL-INDEX) + D ' FLAGS => ' WL-WINDOW-FLAGS (WL-INDEX) D UPON SYSERR SET WL-INDEX UP BY +1 END-PERFORM. D DISPLAY ' =========> END LISTING WINDOWS ' UPON SYSERR. - 3000-EXIT. EXIT. - END PROGRAM SAMPLE. ]) AT_CHECK([$COMPILE prog.cob], [0], [], []) From a51ca02a68d5adedead306dfada270ff85582a0f Mon Sep 17 00:00:00 2001 From: sf-mensch Date: Tue, 19 Nov 2024 20:13:51 +0000 Subject: [PATCH 19/29] follow-up to r5371 - panel update (refactoring) added missing copybook update update to THANKS --- THANKS | 5 +- copy/gcwindow.cpy | 184 +++++++++++++++++++++++++--------------------- 2 files changed, 104 insertions(+), 85 deletions(-) diff --git a/THANKS b/THANKS index 08899d0d2..7f39e20a8 100644 --- a/THANKS +++ b/THANKS @@ -50,7 +50,8 @@ Sergey Kashyrin - For his work on: And continuing this amazing support: Arnold Trembley - Win32 packaging and user support -Chuck Haatvedt - Work on optimized BCD handling +Chuck Haatvedt - Work on optimized BCD handling, + general numeric performance and screenio extensions like WCB Ludwin Janvier - patches for build/packaging issues Hans-Martin Rasch - Work on compiler syntax Michel Gouget - Work on syntax - IS @@ -58,7 +59,7 @@ Bill Klein - The mainstay for COBOL questions Frank Swarbrick - Work on compiler syntax Warren Gay - For testing systems we didn't even know we supported! (e.g. old DEC Alpha systems) -Fabrizio Calabretta - Work on the internal EXTFH interface +Fabrizio Calabretta - Work on the OpenCOBOL internal EXTFH interface Gary L. Cutler and Vincent B. Coen for writing and maintaining the GnuCOBOL Programmer's Guide. diff --git a/copy/gcwindow.cpy b/copy/gcwindow.cpy index 146ddaa8f..50f62128e 100644 --- a/copy/gcwindow.cpy +++ b/copy/gcwindow.cpy @@ -19,91 +19,109 @@ *> License along with GnuCOBOL. *> If not, see . - *>* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * - *> * - *> THIS COMMUNICATION AREA IS USED TO RETRIEVE * - *> INFORMATION ABOUT THE WINDOWS WHICH HAVE BEEN CREATED * - *> BY THE CBL_GC_WINDOW_NEW FUNCTION. IT WILL REPORT ON * - *> ALL OF THE WINDOWS BOTH ACTIVE AND HIDDEN. THE ACTIVE * - *> WINDOWS WILL BE IN ORDER OF THEIR DEPTH ON THE STACK * - *> OF WINDOWS. AN ENTRY OF ALL LOW VALUES WILL REPRESENT * - *> THE NON EXISTANCE OF ANY MORE WINDOWS. * - *> * - *>* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * + *> Modus operandi - 01 WL-WINDOW-LIST. - 05 WL-WINDOW OCCURS 20 TIMES - INDEXED BY WL-INDEX. - 10 WL-DEPTH PIC S9(4) COMP-5. - 10 WL-WINDOW-NUMBER PIC S9(4) COMP-5. - 10 WL-WINDOW-POSITION-ROW PIC S9(4) COMP-5. - 10 WL-WINDOW-POSITION-COL PIC S9(4) COMP-5. - 10 WL-WINDOW-SIZE-ROW PIC S9(4) COMP-5. - 10 WL-WINDOW-SIZE-COL PIC S9(4) COMP-5. - 10 WL-WINDOW-FG-COLOR PIC S9(4) COMP-5. - 10 WL-WINDOW-BG-COLOR PIC S9(4) COMP-5. - 10 WL-WINDOW-HIDDEN PIC S9(4) COMP-5. + *> put the window on the top of the deck of windows + 78 WP-WINDOW-TOP VALUE 'T'. + *> put the window on the bottom of the deck of windows + 78 WP-WINDOW-BOTTOM VALUE 'B'. + + *> create a new window and place it on the top of the deck of windows + 78 WP-WINDOW-NEW VALUE 'N'. + *> physically delete the window from memory + 78 WP-WINDOW-DELETE VALUE 'D'. + + *> get the attributes (position / size / default color) of a window + 78 WP-WINDOW-GET-ATTRIBUTES VALUE 'G'. + *> change the window's attributes (partially implemented) + 78 WP-WINDOW-SET-ATTRIBUTES VALUE 'S'. + + *> the following *MAY* be dropped in favor of [LIST/GET+] SET + *> move the window + 78 WP-WINDOW-MOVE VALUE 'M'. + *> make the window invisible / hide it + 78 WP-WINDOW-HIDE VALUE 'I'. + *> make a previously hidden window visible + 78 WP-WINDOW-SHOW VALUE 'V'. + + *> get list of windows and their attributes + 78 WP-WINDOW-LIST VALUE 'L'. - *>* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * - *> * - *> This copy member is used to call the Multiple Window * - *> CBL_GC_WINDOW functions. Note that the return value * - *> is passed via the COBOL RETURN-CODE; also note that these * - *> functions only work when in extended i/o mode. * - *> See the Programmers Guide for more information on the use * - *> of these functions. * - *> * - *>* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * + *> Optional flags for the windows + 78 WP-FLAG-HIDDEN VALUE h'01'. + 78 WP-FLAG-NOSCROLL VALUE h'02'. + 78 WP-FLAG-NOWRAP VALUE h'04'. + + *> secondary parameter block for all commands + *> but the listingcontaining definitions 01 WP-WINDOW-PARMS. - 05 WP-WINDOW-MODE PIC 9(09) COMP-5. - 88 WP-MODE-NEW-WINDOW VALUE 1. - 88 WP-MODE-DELETE-WINDOW VALUE 2. - 88 WP-MODE-MOVE-WINDOW VALUE 3. - 88 WP-MODE-SHOW-WINDOW VALUE 4. - 88 WP-MODE-HIDE-WINDOW VALUE 5. - 88 WP-MODE-TOP-WINDOW VALUE 6. - 88 WP-MODE-BOTTOM-WINDOW VALUE 7. - *> 88 WP-MODE-LIST-WINDOW VALUE 8. - 05 WP-WINDOW-NUMBER PIC 9(09) COMP-5. - 05 WP-WINDOW-START-ROW PIC 9(09) COMP-5. - 05 WP-WINDOW-START-COL PIC 9(09) COMP-5. - 05 WP-WINDOW-ROWS PIC 9(09) COMP-5. - 05 WP-WINDOW-COLUMNS PIC 9(09) COMP-5. - 05 WP-WINDOW-FG-COLOR PIC 9(09) COMP-5. - 05 WP-WINDOW-BG-COLOR PIC 9(09) COMP-5. - 05 WP-WINDOW-HIDDEN PIC 9(09) COMP-5. + 03 WP-WINDOW-NUMBER USAGE BINARY-SHORT. + 03 WP-WINDOW-ATTRIBUTES. + 05 WP-WINDOW-START-LINE USAGE BINARY-SHORT. + 05 WP-WINDOW-START-COL USAGE BINARY-SHORT. + 05 WP-WINDOW-LINES USAGE BINARY-SHORT. + 05 WP-WINDOW-COLUMNS USAGE BINARY-SHORT. + 05 WP-WINDOW-FG-COLOR USAGE BINARY-SHORT. + 05 WP-WINDOW-BG-COLOR USAGE BINARY-SHORT. + 05 WP-WINDOW-FLAGS USAGE BINARY-SHORT. + + *> convenience variable for possible call after SET WP-MODE-... + 01 WP-WINDOW-MODE PIC X. + 88 WP-MODE-NEW VALUE WP-WINDOW-NEW. + 88 WP-MODE-DELETE VALUE WP-WINDOW-DELETE. + 88 WP-MODE-MOVE VALUE WP-WINDOW-MOVE. + 88 WP-MODE-SHOW VALUE WP-WINDOW-SHOW. + 88 WP-MODE-HIDE VALUE WP-WINDOW-HIDE. + 88 WP-MODE-TOP VALUE WP-WINDOW-TOP. + 88 WP-MODE-BOTTOM VALUE WP-WINDOW-BOTTOM. + 88 WP-MODE-LIST VALUE WP-WINDOW-LIST. + + *> RETURN-CODE value convenience variable allowing named checks + 01 WP-WINDOW-RETURN-CODE USAGE BINARY-INT. + 88 WP-UNSUPPORTED VALUE -1. + 88 WP-DISABLED VALUE -2. + 88 WP-BAD-PARAMETER-LEN VALUE -8. + 88 WP-OK VALUE 0. + 88 WP-LINE-EXCEEDS-MAX VALUE 2. + 88 WP-COL-EXCEEDS-MAX VALUE 4. + 88 WP-WIN-LINES-EXCEEDS-MAX VALUE 6. + 88 WP-WIN-COLS-EXCEEDS-MAX VALUE 7. + 88 WP-INVALID-BG-COLOR VALUE 8. + 88 WP-INVALID-FG-COLOR VALUE 9. + 88 WP-WIN-NUMBER-INVALID VALUE 10. + 88 WP-FG-BG-COLORS-ARE-SAME VALUE 11. + 88 WP-NO-MORE-WINDOWS-LEFT VALUE 20. + 88 WP-NEWWIN-FAILED VALUE 22. + 88 WP-NEW-PANEL-FAILED VALUE 24. + 88 WP-PAN-USRPTR-FAILED VALUE 26. + 88 WP-WINDOW-NOT-FOUND VALUE 28. + 88 WP-MOVE-WINDOW-FAILED VALUE 29. + 88 WP-SHOW-WINDOW-FAILED VALUE 30. + 88 WP-HIDE-WINDOW-FAILED VALUE 32. + 88 WP-TOP-WINDOW-FAILED VALUE 34. + 88 WP-BOTTOM-WINDOW-FAILED VALUE 35. + 88 WP-DELETE-WINDOW-FAILED VALUE 36. + 88 WP-DELETE-PANEL-FAILED VALUE 38. + 88 WP-WINDOW-IS-HIDDEN VALUE 40. + 88 WP-WINDOW-IS-NOT-HIDDEN VALUE 42. + 88 WP-WINDOW-MODE-IS-INVALID VALUE 44. - *> RETURN-CODE value - 01 WP-WINDOW-RETURN-CODE PIC 9(09) COMP-5. - 88 WP-UNSUPPORTED VALUE -1. - 88 WP-DISABLED VALUE -2. - 88 WP-BAD-PARAMETER-LEN VALUE -8. - 88 WP-OK VALUE 0. - 88 WP-START-Y-EXCEEDS-MAX VALUE 2. - 88 WP-START-X-EXCEEDS-MAX VALUE 4. - 88 WP-WIN-ROWS-EXCEEDS-MAX VALUE 6. - 88 WP-WIN-COLS-EXCEEDS-MAX VALUE 7. - 88 WP-INVALID-BG-COLOR VALUE 8. - 88 WP-INVALID-FG-COLOR VALUE 9. - 88 WP-WIN-NUMBER-INVALID VALUE 10. - 88 WP-FG-BG-COLORS-ARE-SAME VALUE 11. - 88 WP-WIN-HIDDEN-NOT-1 VALUE 12. - 88 WP-WIN-HIDDEN-NOT-0 VALUE 14. - 88 WP-TOP-WIN-NBR-INVALID VALUE 16. - 88 WP-BOTTOM-WIN-NBR-INVALID VALUE 18. - 88 WP-NO-MORE-WINDOWS-LEFT VALUE 20. - 88 WP-NEWWIN-FAILED VALUE 22. - 88 WP-NEW-PANEL-FAILED VALUE 24. - 88 WP-PAN-USRPTR-FAILED VALUE 26. - 88 WP-WINDOW-NOT-FOUND VALUE 28. - 88 WP-MOVE-WINDOW-FAILED VALUE 29. - 88 WP-SHOW-WINDOW-FAILED VALUE 30. - 88 WP-HIDE-WINDOW-FAILED VALUE 32. - 88 WP-TOP-WINDOW-FAILED VALUE 34. - 88 WP-BOTTOM-WINDOW-FAILED VALUE 35. - 88 WP-DELETE-WINDOW-FAILED VALUE 36. - 88 WP-DELETE-PANEL-FAILED VALUE 38. - 88 WP-WINDOW-IS-HIDDEN VALUE 40. - 88 WP-WINDOW-IS-NOT-HIDDEN VALUE 42. - 88 WP-WINDOW-MODE-IS-INVALID VALUE 44. + *> communication area to retrieve information about all windows created, + *> including the windows currently hidden; the visible/active ones will + *> be in order of their depth within the visible window-stack; + *> elements that are complete empty (low values) represent the end of + *> used elements + 01 WL-WINDOW-LIST. + 05 WL-WINDOW OCCURS 20 TIMES + INDEXED BY WL-INDEX. + 88 WL-WINDOW-UNUSED VALUE ALL LOW-VALUE. + 10 WL-DEPTH USAGE BINARY-SHORT. + 10 WL-WINDOW-NUMBER USAGE BINARY-SHORT. + 10 WL-WINDOW-POSITION-LINE USAGE BINARY-SHORT. + 10 WL-WINDOW-POSITION-COL USAGE BINARY-SHORT. + 10 WL-WINDOW-SIZE-LINES USAGE BINARY-SHORT. + 10 WL-WINDOW-SIZE-COLS USAGE BINARY-SHORT. + 10 WL-WINDOW-FG-COLOR USAGE BINARY-SHORT. + 10 WL-WINDOW-BG-COLOR USAGE BINARY-SHORT. + 10 WL-WINDOW-FLAGS USAGE BINARY-SHORT. From d5eb0eb02335042b507d69f86d48ed6cd79346a4 Mon Sep 17 00:00:00 2001 From: sf-mensch Date: Tue, 19 Nov 2024 21:38:57 +0000 Subject: [PATCH 20/29] follow-up to r5369 - panel update * configure.ac: fix check for panel lib when curses is disabled * doc/gnucobol.texi: update (still TODO) * libcob/screenio.c: fix compiler error in case of missing panel support --- configure.ac | 6 ++++-- doc/gnucobol.texi | 24 ++++++++++++------------ libcob/screenio.c | 4 +++- 3 files changed, 19 insertions(+), 15 deletions(-) diff --git a/configure.ac b/configure.ac index c0b012267..2466227f5 100644 --- a/configure.ac +++ b/configure.ac @@ -1527,8 +1527,10 @@ if test "x$CURSES_LIBS" = x; then AC_CHECK_LIB([curses], [initscr], [true], [AS_IF([test "$USE_CURSES" != check], [USE_CURSES="missing_lib"])]) fi - if test "x$PANEL_LIBS" = x; then - AC_CHECK_LIB([panel], [new_panel], [PANEL_LIBS=-lpanel]) + if test "$USE_CURSES" = "curses" -o "$USE_CURSES" = check; then + if test "x$PANEL_LIBS" = x; then + AC_CHECK_LIB([panel], [new_panel], [PANEL_LIBS=-lpanel]) + fi fi fi if test "$USE_CURSES" = "curses" -o "x$ac_cv_lib_curses_initscr" = xyes; then diff --git a/doc/gnucobol.texi b/doc/gnucobol.texi index 2d0f38afa..b65511412 100644 --- a/doc/gnucobol.texi +++ b/doc/gnucobol.texi @@ -2839,21 +2839,21 @@ or list multiple windows if your installation supports CURSES & PANELS. Note windows have depth like a stack of cards on a flat table. Each window has its contents independent of any other window. All of the writes to the console are directed to the window on top of the deck of windows. -Note that you need to check the COBOL RETURN-CODE and the WP-RETURN-CODE -after calling CBL_GC_WINDOW. -Parameters: the WP-PARM.CPY copy member is used for all calls except -the LIST function which uses the WP-LIST.CPY copy member. See the -programmers guide for more information about the required parameters -which need to be used for the different function modes -Returns: COBOL RETURN-CODE and WP-RETURN-CODE (except for LIST function). -The non-zero RETURN-CODE is used to indicate either that PANEL functions -are not available in your installation of GNUCOBOL or the parm that you -used is not the correct length. +Parameters: the gcwindow.cpy copy member defines all parameters for this +function. All commands but the the LIST command uses the same secondary +parameter @code{WP-WINDOW-PARMS}, the LIST command uses @code{WL-WINDOW-LIST} instead. + +TODO explain the parameters + +Returns: COBOL RETURN-CODE contains general error code (like not available +PANEL function in the curses runtime library) and specific problems depending +on the parameters, zero means "no error". +You can use @code{RETURNING WP-WINDOW-RETURN-CODE} to use the condition-names +for more detailed error handling, otherwise use those as reference. @example - see the programmers guide for a sample program as it is a - bit too large to include here. + TODO @end example @node Appendices diff --git a/libcob/screenio.c b/libcob/screenio.c index 0ce956a87..0d9b5c3d9 100644 --- a/libcob/screenio.c +++ b/libcob/screenio.c @@ -5868,7 +5868,7 @@ cob_sys_window (unsigned char *mode_ext, unsigned char *fld) return 44; } -#else +#else /* WITH_PANELS */ if (getenv ("COB_IS_RUNNING_IN_TESTMODE")) { return 77; /* let testsuite skip related tests */ } @@ -5879,6 +5879,7 @@ cob_sys_window (unsigned char *mode_ext, unsigned char *fld) #else /* COB_EXPERIMENTAL */ COB_UNUSED (mode_ext); COB_UNUSED (fld); +#ifdef WITH_PANELS COB_UNUSED (sys_window_new); COB_UNUSED (sys_window_delete); COB_UNUSED (sys_window_move); @@ -5887,6 +5888,7 @@ cob_sys_window (unsigned char *mode_ext, unsigned char *fld) COB_UNUSED (sys_window_top); COB_UNUSED (sys_window_bottom); COB_UNUSED (sys_window_list); +#endif if (getenv ("COB_IS_RUNNING_IN_TESTMODE")) { return 77; /* let testsuite skip related tests */ } From 16e84a584d7edf41100db524ab9bb7e195d2004c Mon Sep 17 00:00:00 2001 From: David Declerck Date: Sun, 24 Nov 2024 17:14:57 +0100 Subject: [PATCH 21/29] Fix macOS CI --- .github/workflows/macos.yml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.github/workflows/macos.yml b/.github/workflows/macos.yml index 28ccbce6b..3e5e2b8e3 100644 --- a/.github/workflows/macos.yml +++ b/.github/workflows/macos.yml @@ -27,7 +27,7 @@ jobs: - name: Install packages run: | - brew install pkg-config automake libtool help2man texinfo bison berkeley-db@4 json-c + brew install automake libtool help2man texinfo bison berkeley-db@4 json-c opt="/opt/homebrew/opt" echo "$opt/pkg-config/bin" >> $GITHUB_PATH echo "LDFLAGS=-L$opt/berkeley-db@4/lib ${LDFLAGS}" >> $GITHUB_ENV From 87c1dd5799ff72425b6ede1efa3b2a789610e2a2 Mon Sep 17 00:00:00 2001 From: ddeclerck Date: Mon, 2 Dec 2024 09:23:03 +0000 Subject: [PATCH 22/29] Fixed [bugs:#1008] regression in move to numeric edited items * move.c (optimized_move_display_to_edited): fixed Bug #1008: regression in move to numeric edited items with insertion symbols B, 0 and / * move.c (optimized_move_display_to_edited): minor refactoring * exception.def, move.c: added definition for COBOL2025 COB_EC_DATA_NULL + COB_EC_DATA_TRUNCATION (currently not used) --- libcob/ChangeLog | 10 ++ libcob/exception.def | 9 ++ libcob/move.c | 107 ++++++++++++++-------- tests/testsuite.src/run_fundamental.at | 121 ++++++++++++++++++++++++- 4 files changed, 205 insertions(+), 42 deletions(-) diff --git a/libcob/ChangeLog b/libcob/ChangeLog index fe027fa16..91bf144e0 100644 --- a/libcob/ChangeLog +++ b/libcob/ChangeLog @@ -1,5 +1,15 @@ +2024-11-22 David Declerck + * move.c (optimized_move_display_to_edited): minor refactoring + * exception.def, move.c: added definition for COBOL2025 + COB_EC_DATA_NULL + COB_EC_DATA_TRUNCATION (currently not used) + +2024-11-22 Chuck Haatvedt + + * move.c (optimized_move_display_to_edited): fixed + Bug #1008: regression in move to numeric edited + items with insertion symbols B, 0 and / 2024-11-19 Simon Sobisch diff --git a/libcob/exception.def b/libcob/exception.def index 9cd643ca4..9e70c53c7 100644 --- a/libcob/exception.def +++ b/libcob/exception.def @@ -122,6 +122,15 @@ COB_EXCEPTION (0305, COB_EC_DATA_OVERFLOW, COB_EXCEPTION (0306, COB_EC_DATA_PTR_NULL, "EC-DATA-PTR-NULL", 1) +/* Attempt to use a null valued data item in a context where not permitted (COBOL2025) */ +COB_EXCEPTION (0307, COB_EC_DATA_NULL, + "EC-DATA-NULL", 1) + +/* A non-space or significant-digit was truncated during MOVE (COBOL2025) */ +COB_EXCEPTION (0308, COB_EC_DATA_TRUNCATION, + "EC-DATA-TRUNCATION", 0) + + /* EXTERNAL item mismatch (COBOL 202x) */ COB_EXCEPTION (1900, COB_EC_EXTERNAL, diff --git a/libcob/move.c b/libcob/move.c index 053bbf246..b96667b28 100644 --- a/libcob/move.c +++ b/libcob/move.c @@ -156,6 +156,19 @@ store_common_region (cob_field *f, const unsigned char *data, const int hf2 = fsize + lf2; const int gcf = cob_min_int (hf1, hf2); +#if 0 /* TODO: globally add support for COB_EC_DATA_TRUNCATION */ + const unsigned char *p = data; + const unsigned char *end = data + hf1 - gcf; + while (p < end) { + if ((COB_FIELD_IS_NUMERIC (f) && (*p != '0')) + || (COB_FIELD_IS_ANY_ALNUM (f) && (*p != ' '))) { + cob_set_exception (COB_EC_DATA_TRUNCATION); + break; + } + ++p; + } +#endif + /* the target may have leading/trailing additional zeroes and in rare cases, we may be out of scale competely; we pre-set all positions as this saves a bunch of @@ -1011,18 +1024,15 @@ optimized_move_display_to_edited (cob_field *f1, cob_field *f2) int suppress_zero = 1; int have_decimal_point = 0; int have_check_protect = 0; - int n; int cntr_currency = 0; - int cntr_sign_neg = 0; - int cntr_sign_pos = 0; + int cntr_sign = 0; unsigned char pad = ' '; unsigned char c; unsigned char float_char = 0x00; - const unsigned char dec_symbol = COB_MODULE_PTR->decimal_point == ',' - ? ',' : '.'; + const unsigned char dec_symbol = COB_MODULE_PTR->decimal_point == ',' ? ',' : '.'; const unsigned char currency = COB_MODULE_PTR->currency_symbol; -#if 1 /* Sanity check to ensure that the data types of both the fields have the +#ifndef NDEBUG /* Sanity check to ensure that the data types of both the fields have the correct attributes, if not then something is brokend and needs to be fixed */ if (!(COB_FIELD_TYPE (f2) == COB_TYPE_NUMERIC_EDITED && COB_FIELD_DIGITS (f1) == COB_FIELD_DIGITS (f2) @@ -1048,21 +1058,17 @@ optimized_move_display_to_edited (cob_field *f1, cob_field *f2) for (p = COB_FIELD_PIC (f2); p->symbol; ++p) { c = p->symbol; - n = p->times_repeated; if ((c == '9') || (c == 'Z') || (c == '*') || (c == 'C') || (c == 'D')) { break; - } else if (c == '-') { - cntr_sign_neg += n; - if (cntr_sign_neg > 1) break; - } else if (c == '+') { - cntr_sign_pos += n; - if (cntr_sign_pos > 1) break; + } else if ((c == '-') || (c == '+')) { + cntr_sign += p->times_repeated; + if (cntr_sign > 1) break; } else if (c == currency) { - cntr_currency += n; + cntr_currency += p->times_repeated; if (cntr_currency > 1) break; } } @@ -1079,30 +1085,38 @@ optimized_move_display_to_edited (cob_field *f1, cob_field *f2) } /* first check for BLANK WHEN ZERO attribute */ - if (COB_FIELD_BLANK_ZERO(f2)) { - for(; (src <= src_end) ; src++) { + if (COB_FIELD_BLANK_ZERO (f2)) { + for (; (src <= src_end) ; src++) { if (*src != '0') break; } if (src > src_end) { - memset(dst, (int)' ', (size_t)f2->size); + memset (dst, (int)' ', (size_t)f2->size); return; } src = f1->data; } - if (COB_FIELD_HAVE_SIGN(f1)) + if (COB_FIELD_HAVE_SIGN (f1)) { neg = (*src_end == '-') ? 1 : 0; + } for (p = COB_FIELD_PIC (f2); p->symbol; ++p) { + int n; c = p->symbol; - n = p->times_repeated; - if (c == 'P') + if (c == 'P') { continue; - for (; n > 0; n--) { + } + if (c == 'V') { + have_decimal_point = 1; + continue; + } + for (n = p->times_repeated; n > 0; n--) { +#ifndef NDEBUG if (dst >= dst_end) { cob_runtime_error ("optimized_move_display_to_edited: overflow in destination field"); break; } +#endif switch (c) { case '9': @@ -1121,8 +1135,9 @@ optimized_move_display_to_edited (cob_field *f1, cob_field *f2) if (*src != '0') { is_zero = suppress_zero = 0; } else { - if (suppress_zero && (!have_decimal_point)) + if (suppress_zero && (!have_decimal_point)) { *dst = pad; + } } src++; dst++; @@ -1134,8 +1149,9 @@ optimized_move_display_to_edited (cob_field *f1, cob_field *f2) if (*src != '0') { is_zero = suppress_zero = 0; } else { - if (suppress_zero && (!have_decimal_point)) + if (suppress_zero && (!have_decimal_point)) { *dst = pad; + } } src++; dst++; @@ -1184,11 +1200,13 @@ optimized_move_display_to_edited (cob_field *f1, cob_field *f2) *dst = *prev_float_char; *prev_float_char = pad; prev_float_char = dst; - if (*dst == '-' || *dst == '+') + if (*dst == '-' || *dst == '+') { sign_position = dst; + } } - else + else { *dst = pad; + } } else { *dst = c; } @@ -1197,12 +1215,20 @@ optimized_move_display_to_edited (cob_field *f1, cob_field *f2) break; case 'V': - have_decimal_point = 1; break; case '0': case '/': - *dst = c; + if (suppress_zero && prev_float_char) { + *dst = *prev_float_char; + *prev_float_char = pad; + prev_float_char = dst; + if (*dst != currency) { + sign_position = dst; + } + } else { + *dst = c; + } dst++; break; @@ -1211,6 +1237,9 @@ optimized_move_display_to_edited (cob_field *f1, cob_field *f2) *dst = *prev_float_char; *prev_float_char = pad; prev_float_char = dst; + if (*dst != currency) { + sign_position = dst; + } } else if (have_check_protect) { *dst = pad; } else { @@ -1283,36 +1312,36 @@ optimized_move_display_to_edited (cob_field *f1, cob_field *f2) /* if we have not printed any digits set destination to spaces and return */ - if (suppress_zero){ - if (pad == '*'){ - for(dst = f2->data; dst < dst_end; dst++) { - if (*dst != dec_symbol){ + if (suppress_zero) { + if (pad == '*') { + for (dst = f2->data; dst < dst_end; dst++) { + if (*dst != dec_symbol) { *dst = '*'; } } } else { - memset(f2->data, ' ', f2->size); + memset (f2->data, ' ', f2->size); return; } } - if (sign_position == NULL) + if (sign_position == NULL) { return; + } - if ((neg) && (*sign_position == '+')){ + if ((neg) && (*sign_position == '+')) { *sign_position = (is_zero) ? '+' : '-'; return; } - if ((neg) && (*sign_position == '-')){ + if ((neg) && (*sign_position == '-')) { *sign_position = (is_zero) ? ' ' : '-'; return; - } - + } - if ((*sign_position == '-') && (!neg)) + if ((*sign_position == '-') && (!neg)) { *sign_position = ' '; - + } } diff --git a/tests/testsuite.src/run_fundamental.at b/tests/testsuite.src/run_fundamental.at index 7d450ef6a..db37ca0ee 100644 --- a/tests/testsuite.src/run_fundamental.at +++ b/tests/testsuite.src/run_fundamental.at @@ -1980,13 +1980,13 @@ AT_DATA([prog.cob], [ MOVE 10 TO identifier-1 MOVE identifier-1 TO EX-13 - IF EX-13 EQUAL " $//00//10 " + IF EX-13 EQUAL " $00//10 " MOVE "PASS" TO MSG-1 - D DISPLAY " $//00//10 IS WHAT I EXPECTED" + D DISPLAY " $00//10 IS WHAT I EXPECTED" ELSE ADD 1 TO WS-COUNT MOVE "FAIL" TO MSG-1 - DISPLAY "EX-13.02 EXPECTING ==>' $//00//10 ' " + DISPLAY "EX-13.02 EXPECTING ==>' $00//10 ' " "WHAT I GOT WAS ==>'" EX-13 "'<==" D DISPLAY "------------------" MSG-1 @@ -2510,6 +2510,121 @@ AT_CHECK([$COBCRUN_DIRECT ./prog], [0], AT_CLEANUP +AT_SETUP([MOVE to item with +, -, B, 0, / and ,]) +AT_KEYWORDS([fundamental edited editing]) + +AT_DATA([prog.cob], [ + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 W-P4 PIC S9 VALUE +4. + 01 W-M4 PIC S9 VALUE -4. + 01 W-M PIC -B- VALUE SPACES. + 01 W-P PIC +B+ VALUE SPACES. + + 01 W-P123 PIC S9(3) VALUE +123. + 01 W-M123 PIC S9(3) VALUE -123. + 01 W-MM PIC ---B--9 VALUE SPACES. + 01 W-PP PIC +++B++9 VALUE SPACES. + + 01 W-X PIC -//00BB,,- VALUE SPACES. + + PROCEDURE DIVISION. + MOVE W-P4 TO W-M. + DISPLAY W-M. + MOVE W-M4 TO W-M. + DISPLAY W-M. + MOVE W-P4 TO W-P. + DISPLAY W-P. + MOVE W-M4 TO W-P. + DISPLAY W-P. + + MOVE W-P123 TO W-MM. + DISPLAY W-MM. + MOVE W-M123 TO W-MM. + DISPLAY W-MM. + MOVE W-P123 TO W-PP. + DISPLAY W-PP. + MOVE W-M123 TO W-PP. + DISPLAY W-PP. + + MOVE W-P4 TO W-X. + DISPLAY W-X. + MOVE W-M4 TO W-X. + DISPLAY W-X. + + MOVE W-P123 TO W-X. + DISPLAY W-X. + MOVE W-M123 TO W-X. + DISPLAY W-X. + + STOP RUN. +]) + +AT_CHECK([$COMPILE prog.cob], [0], [], []) +AT_CHECK([$COBCRUN_DIRECT ./prog], [0], +[ 4 + -4 + +4 + -4 + 123 + -123 + +123 + -123 + 4 + -4 + 3 + -3 +]) + +AT_CLEANUP + + +AT_SETUP([MOVE to shorter edited item (truncation)]) +AT_KEYWORDS([fundamental edited editing]) + +AT_DATA([prog.cob], [ + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 W-SRC1 PIC 999V99 VALUE 123.45. + 01 W-SRC2 PIC 9999V9 VALUE 1234.5. + 01 W-SRC3 PIC 99999V VALUE 12345. + 01 W-DST1 PIC ZZZV. + 01 W-DST2 PIC ZZZZZV. + + PROCEDURE DIVISION. + MOVE W-SRC1 TO W-DST1. + DISPLAY W-DST1. + MOVE W-SRC2 TO W-DST1. + DISPLAY W-DST1. + MOVE W-SRC3 TO W-DST1. + DISPLAY W-DST1. + MOVE W-SRC1 TO W-DST2. + DISPLAY W-DST2. + MOVE W-SRC2 TO W-DST2. + DISPLAY W-DST2. + MOVE W-SRC3 TO W-DST2. + DISPLAY W-DST2 WITH NO ADVANCING. + STOP RUN. +]) + +AT_CHECK([$COMPILE prog.cob], [0], [], []) +AT_CHECK([$COBCRUN_DIRECT ./prog], [0], +[123 +234 +345 + 123 + 1234 +12345]) + +AT_CLEANUP + + AT_SETUP([MOVE to JUSTIFIED item]) AT_KEYWORDS([fundamental]) From c2ee239a5209c0a99d5fae8b76ad86d4c7225103 Mon Sep 17 00:00:00 2001 From: sf-mensch Date: Sun, 8 Dec 2024 11:58:27 +0000 Subject: [PATCH 23/29] follow-up to r5369 - panel update * configure.ac: fix fix check for curses functions if panel headers are found --- ChangeLog | 4 ++ configure.ac | 108 ++++++++++++++++++++++++++++++++++++++++++++++++--- 2 files changed, 106 insertions(+), 6 deletions(-) diff --git a/ChangeLog b/ChangeLog index 856a4be31..6e4c9346e 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,4 +1,8 @@ +2024-12-08 Simon Sobisch + + * configure.ac: fix check for curses functions if panel headers are found + 2024-10-30 Simon Sobisch * configure.ac: added logic to check for PANEL support which diff --git a/configure.ac b/configure.ac index 2466227f5..dec5ed758 100644 --- a/configure.ac +++ b/configure.ac @@ -1583,7 +1583,17 @@ fi if test "$USE_CURSES" != no -a "$USE_CURSES" != "not_found"; then AC_MSG_CHECKING([for curses color_set function]) AC_LINK_IFELSE([AC_LANG_PROGRAM([[ - #ifdef HAVE_NCURSESW_NCURSES_H + #if defined (HAVE_NCURSESW_PANEL_H) + #include + #elif defined (HAVE_NCURSES_PANEL_H) + #include + #elif defined (HAVE_PDCURSES_PANEL_H) + #include + #elif defined (HAVE_XCURSES_PANEL_H) + #include + #elif defined (HAVE_PANEL_H) + #include + #if defined (HAVE_NCURSESW_NCURSES_H) #include #elif defined (HAVE_NCURSESW_CURSES_H) #include @@ -1593,6 +1603,12 @@ if test "$USE_CURSES" != no -a "$USE_CURSES" != "not_found"; then #include #elif defined (HAVE_PDCURSES_H) #include + #elif defined (HAVE_PDCURSES_CURSES_H) + #include + #elif defined (HAVE_XCURSES_H) + #include + #elif defined (HAVE_XCURSES_CURSES_H) + #include #elif defined (HAVE_CURSES_H) #include #endif]], [[ @@ -1604,7 +1620,17 @@ if test "$USE_CURSES" != no -a "$USE_CURSES" != "not_found"; then AC_MSG_CHECKING([for curses resize_term function]) AC_LINK_IFELSE([AC_LANG_PROGRAM([[ - #ifdef HAVE_NCURSESW_NCURSES_H + #if defined (HAVE_NCURSESW_PANEL_H) + #include + #elif defined (HAVE_NCURSES_PANEL_H) + #include + #elif defined (HAVE_PDCURSES_PANEL_H) + #include + #elif defined (HAVE_XCURSES_PANEL_H) + #include + #elif defined (HAVE_PANEL_H) + #include + #if defined (HAVE_NCURSESW_NCURSES_H) #include #elif defined (HAVE_NCURSESW_CURSES_H) #include @@ -1614,6 +1640,12 @@ if test "$USE_CURSES" != no -a "$USE_CURSES" != "not_found"; then #include #elif defined (HAVE_PDCURSES_H) #include + #elif defined (HAVE_PDCURSES_CURSES_H) + #include + #elif defined (HAVE_XCURSES_H) + #include + #elif defined (HAVE_XCURSES_CURSES_H) + #include #elif defined (HAVE_CURSES_H) #include #endif]], [[ @@ -1625,7 +1657,17 @@ if test "$USE_CURSES" != no -a "$USE_CURSES" != "not_found"; then AC_MSG_CHECKING([for curses define_key function]) AC_LINK_IFELSE([AC_LANG_PROGRAM([[ - #ifdef HAVE_NCURSESW_NCURSES_H + #if defined (HAVE_NCURSESW_PANEL_H) + #include + #elif defined (HAVE_NCURSES_PANEL_H) + #include + #elif defined (HAVE_PDCURSES_PANEL_H) + #include + #elif defined (HAVE_XCURSES_PANEL_H) + #include + #elif defined (HAVE_PANEL_H) + #include + #if defined (HAVE_NCURSESW_NCURSES_H) #include #elif defined (HAVE_NCURSESW_CURSES_H) #include @@ -1635,6 +1677,12 @@ if test "$USE_CURSES" != no -a "$USE_CURSES" != "not_found"; then #include #elif defined (HAVE_PDCURSES_H) #include + #elif defined (HAVE_PDCURSES_CURSES_H) + #include + #elif defined (HAVE_XCURSES_H) + #include + #elif defined (HAVE_XCURSES_CURSES_H) + #include #elif defined (HAVE_CURSES_H) #include #endif]], [[ @@ -1646,7 +1694,17 @@ if test "$USE_CURSES" != no -a "$USE_CURSES" != "not_found"; then AC_MSG_CHECKING([for curses mouseinterval function]) AC_LINK_IFELSE([AC_LANG_PROGRAM([[ - #ifdef HAVE_NCURSESW_NCURSES_H + #if defined (HAVE_NCURSESW_PANEL_H) + #include + #elif defined (HAVE_NCURSES_PANEL_H) + #include + #elif defined (HAVE_PDCURSES_PANEL_H) + #include + #elif defined (HAVE_XCURSES_PANEL_H) + #include + #elif defined (HAVE_PANEL_H) + #include + #if defined (HAVE_NCURSESW_NCURSES_H) #include #elif defined (HAVE_NCURSESW_CURSES_H) #include @@ -1656,6 +1714,12 @@ if test "$USE_CURSES" != no -a "$USE_CURSES" != "not_found"; then #include #elif defined (HAVE_PDCURSES_H) #include + #elif defined (HAVE_PDCURSES_CURSES_H) + #include + #elif defined (HAVE_XCURSES_H) + #include + #elif defined (HAVE_XCURSES_CURSES_H) + #include #elif defined (HAVE_CURSES_H) #include #endif]], [[ @@ -1667,7 +1731,17 @@ if test "$USE_CURSES" != no -a "$USE_CURSES" != "not_found"; then AC_MSG_CHECKING([for curses has_mouse function]) AC_LINK_IFELSE([AC_LANG_PROGRAM([[ - #ifdef HAVE_NCURSESW_NCURSES_H + #if defined (HAVE_NCURSESW_PANEL_H) + #include + #elif defined (HAVE_NCURSES_PANEL_H) + #include + #elif defined (HAVE_PDCURSES_PANEL_H) + #include + #elif defined (HAVE_XCURSES_PANEL_H) + #include + #elif defined (HAVE_PANEL_H) + #include + #if defined (HAVE_NCURSESW_NCURSES_H) #include #elif defined (HAVE_NCURSESW_CURSES_H) #include @@ -1677,6 +1751,12 @@ if test "$USE_CURSES" != no -a "$USE_CURSES" != "not_found"; then #include #elif defined (HAVE_PDCURSES_H) #include + #elif defined (HAVE_PDCURSES_CURSES_H) + #include + #elif defined (HAVE_XCURSES_H) + #include + #elif defined (HAVE_XCURSES_CURSES_H) + #include #elif defined (HAVE_CURSES_H) #include #endif]], [[ @@ -1688,7 +1768,17 @@ if test "$USE_CURSES" != no -a "$USE_CURSES" != "not_found"; then AC_MSG_CHECKING([for curses mousemask function and mmask_t]) AC_LINK_IFELSE([AC_LANG_PROGRAM([[ - #ifdef HAVE_NCURSESW_NCURSES_H + #if defined (HAVE_NCURSESW_PANEL_H) + #include + #elif defined (HAVE_NCURSES_PANEL_H) + #include + #elif defined (HAVE_PDCURSES_PANEL_H) + #include + #elif defined (HAVE_XCURSES_PANEL_H) + #include + #elif defined (HAVE_PANEL_H) + #include + #if defined (HAVE_NCURSESW_NCURSES_H) #include #elif defined (HAVE_NCURSESW_CURSES_H) #include @@ -1698,6 +1788,12 @@ if test "$USE_CURSES" != no -a "$USE_CURSES" != "not_found"; then #include #elif defined (HAVE_PDCURSES_H) #include + #elif defined (HAVE_PDCURSES_CURSES_H) + #include + #elif defined (HAVE_XCURSES_H) + #include + #elif defined (HAVE_XCURSES_CURSES_H) + #include #elif defined (HAVE_CURSES_H) #include #endif]], [[ From 7bddf706da7a96a5382c7523117ef792e1774490 Mon Sep 17 00:00:00 2001 From: sf-mensch Date: Sun, 8 Dec 2024 12:08:22 +0000 Subject: [PATCH 24/29] fix copy+paste error in r5389 --- libcob/screenio.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/libcob/screenio.c b/libcob/screenio.c index 0d9b5c3d9..5d775ad94 100644 --- a/libcob/screenio.c +++ b/libcob/screenio.c @@ -5525,7 +5525,7 @@ sys_window_hide (PPARM_FLD parm) back_color = ptr_pan_entry->bg_color; } else { mywin = stdscr; - move(save_cursor_y, save_cursor_x); + move (save_cursor_y, save_cursor_x); fore_color = stdscr_fore_color; back_color = stdscr_back_color; } From dda41815fe1fe00f0c58c6ab348f9ff94546017d Mon Sep 17 00:00:00 2001 From: sf-mensch Date: Sun, 8 Dec 2024 12:08:41 +0000 Subject: [PATCH 25/29] fix copy+paste error in r5389 --- configure.ac | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/configure.ac b/configure.ac index dec5ed758..e0ccc4afc 100644 --- a/configure.ac +++ b/configure.ac @@ -1593,7 +1593,7 @@ if test "$USE_CURSES" != no -a "$USE_CURSES" != "not_found"; then #include #elif defined (HAVE_PANEL_H) #include - #if defined (HAVE_NCURSESW_NCURSES_H) + #elif defined (HAVE_NCURSESW_NCURSES_H) #include #elif defined (HAVE_NCURSESW_CURSES_H) #include @@ -1630,7 +1630,7 @@ if test "$USE_CURSES" != no -a "$USE_CURSES" != "not_found"; then #include #elif defined (HAVE_PANEL_H) #include - #if defined (HAVE_NCURSESW_NCURSES_H) + #elif defined (HAVE_NCURSESW_NCURSES_H) #include #elif defined (HAVE_NCURSESW_CURSES_H) #include @@ -1667,7 +1667,7 @@ if test "$USE_CURSES" != no -a "$USE_CURSES" != "not_found"; then #include #elif defined (HAVE_PANEL_H) #include - #if defined (HAVE_NCURSESW_NCURSES_H) + #elif defined (HAVE_NCURSESW_NCURSES_H) #include #elif defined (HAVE_NCURSESW_CURSES_H) #include @@ -1704,7 +1704,7 @@ if test "$USE_CURSES" != no -a "$USE_CURSES" != "not_found"; then #include #elif defined (HAVE_PANEL_H) #include - #if defined (HAVE_NCURSESW_NCURSES_H) + #elif defined (HAVE_NCURSESW_NCURSES_H) #include #elif defined (HAVE_NCURSESW_CURSES_H) #include @@ -1741,7 +1741,7 @@ if test "$USE_CURSES" != no -a "$USE_CURSES" != "not_found"; then #include #elif defined (HAVE_PANEL_H) #include - #if defined (HAVE_NCURSESW_NCURSES_H) + #elif defined (HAVE_NCURSESW_NCURSES_H) #include #elif defined (HAVE_NCURSESW_CURSES_H) #include @@ -1778,7 +1778,7 @@ if test "$USE_CURSES" != no -a "$USE_CURSES" != "not_found"; then #include #elif defined (HAVE_PANEL_H) #include - #if defined (HAVE_NCURSESW_NCURSES_H) + #elif defined (HAVE_NCURSESW_NCURSES_H) #include #elif defined (HAVE_NCURSESW_CURSES_H) #include From dca86ab692a474a1e77c801119dcf42e3c9c207e Mon Sep 17 00:00:00 2001 From: sf-mensch Date: Sun, 8 Dec 2024 14:35:15 +0000 Subject: [PATCH 26/29] follow-up to r5369 - panel update (portability fix) * libcob/screenio.c [WITH_PANELS]: replace use of ncurses extension ceiling_panel() with X/Open Curses function panel_below() --- libcob/ChangeLog | 5 +++++ libcob/screenio.c | 20 ++++++++++---------- 2 files changed, 15 insertions(+), 10 deletions(-) diff --git a/libcob/ChangeLog b/libcob/ChangeLog index 91bf144e0..0c2f7f405 100644 --- a/libcob/ChangeLog +++ b/libcob/ChangeLog @@ -1,4 +1,9 @@ +2024-12-08 Simon Sobisch + + * screenio.c [WITH_PANELS]: replace use of ncurses extension ceiling_panel() + with X/Open Curses function panel_below() + 2024-11-22 David Declerck * move.c (optimized_move_display_to_edited): minor refactoring diff --git a/libcob/screenio.c b/libcob/screenio.c index 5d775ad94..a1a06cef2 100644 --- a/libcob/screenio.c +++ b/libcob/screenio.c @@ -4692,7 +4692,7 @@ cob_exit_screen (void) #endif #ifdef WITH_PANELS for (;;) { - PANEL *ptr_pan = ceiling_panel (NULL); + PANEL *ptr_pan = panel_below (NULL); if (ptr_pan) { mywin = panel_window (ptr_pan); del_panel (ptr_pan); @@ -5292,7 +5292,7 @@ static void update_all_windows (void) { /* first get the top panel */ - PANEL *ptr_pan = ceiling_panel (NULL); + PANEL *ptr_pan = panel_below (NULL); if (!ptr_pan) { mywin = stdscr; @@ -5423,7 +5423,7 @@ sys_window_move (PPARM_FLD parm) /* CHECKME: why do we use the top panel here, when we moved another panel before ?!? */ - ptr_pan = ceiling_panel (NULL); + ptr_pan = panel_below (NULL); mywin = panel_window (ptr_pan); #if 0 /* to be tested */ @@ -5472,7 +5472,7 @@ sys_window_show (PPARM_FLD parm) ptr_pan_entry->flags = ~SYS_WIN_FLAG_HIDDEN; - ptr_pan = ceiling_panel (NULL); + ptr_pan = panel_below (NULL); mywin = panel_window (ptr_pan); ptr_pan_entry = (PPANEL_ENTRY)panel_userptr (ptr_pan); fore_color = ptr_pan_entry->fg_color; @@ -5516,7 +5516,7 @@ sys_window_hide (PPARM_FLD parm) /* note the following is needed in case the top panel was hidden. then the next panel will be on top */ - ptr_pan = ceiling_panel (NULL); + ptr_pan = panel_below (NULL); if (ptr_pan) { mywin = panel_window (ptr_pan); @@ -5562,7 +5562,7 @@ sys_window_top (PPARM_FLD parm) return 34; } - ptr_pan = ceiling_panel (NULL); + ptr_pan = panel_below (NULL); mywin = panel_window (ptr_pan); ptr_pan_entry = (PPANEL_ENTRY)panel_userptr (ptr_pan); fore_color = ptr_pan_entry->fg_color; @@ -5600,9 +5600,9 @@ sys_window_bottom (PPARM_FLD parm) return 35; } - ptr_pan = ceiling_panel (NULL); - ptr_pan_entry = (PPANEL_ENTRY)panel_userptr (ptr_pan); + ptr_pan = panel_below (NULL); mywin = panel_window (ptr_pan); + ptr_pan_entry = (PPANEL_ENTRY)panel_userptr (ptr_pan); parm->pan_number = ptr_pan_entry->pan_number; fore_color = ptr_pan_entry->fg_color; back_color = ptr_pan_entry->bg_color; @@ -5654,7 +5654,7 @@ sys_window_delete (PPARM_FLD parm) ptr_pan_entry->input_fg_color = 0; ptr_pan_entry->input_bg_color = 7; - ptr_pan = ceiling_panel (NULL); + ptr_pan = panel_below (NULL); if (ptr_pan) { mywin = panel_window (ptr_pan); @@ -5698,7 +5698,7 @@ sys_window_list (PLIST_FLD list, size_t amount) /* find the depth of all the active windows, starting at ceiling (top of deck) and work down... */ - ptr_pan = ceiling_panel (NULL); + ptr_pan = panel_below (NULL); while (ptr_pan && depth <= amount) { ptr_pan_entry = (PPANEL_ENTRY)panel_userptr (ptr_pan); list->pan_position = depth; From b162a03c3d9446b6c549b7c571fdc4f2272b0434 Mon Sep 17 00:00:00 2001 From: sf-mensch Date: Sun, 8 Dec 2024 17:00:11 +0000 Subject: [PATCH 27/29] minor update for sanitizers * cobc/cobc.c (process_command_line): fix leak for --copy and -include parsing * tests/testsuite.src/run_misc.at: skip "write to internal storage" test when cobc was built with sanitizers --- cobc/ChangeLog | 4 ++++ cobc/cobc.c | 4 ++-- tests/testsuite.src/run_misc.at | 1 + 3 files changed, 7 insertions(+), 2 deletions(-) diff --git a/cobc/ChangeLog b/cobc/ChangeLog index 962ce3023..fea626e9a 100644 --- a/cobc/ChangeLog +++ b/cobc/ChangeLog @@ -1,4 +1,8 @@ +2022-12-08 Simon Sobisch + + * cobc.c (process_command_line): fix leak for --copy and -include parsing + 2024-10-30 Chuck Haatvedt * typeck.c: define [WITH_EXTENDED_SCREENIO] for any curses headers diff --git a/cobc/cobc.c b/cobc/cobc.c index de9c1d6f1..34b38a8da 100644 --- a/cobc/cobc.c +++ b/cobc/cobc.c @@ -4029,7 +4029,7 @@ process_command_line (const int argc, char **argv) if (strlen (cob_optarg) > (COB_MINI_MAX)) { cobc_err_exit (COBC_INV_PAR, "--copy"); } - CB_TEXT_LIST_ADD (cb_copy_list, cobc_strdup (cob_optarg)); + CB_TEXT_LIST_ADD (cb_copy_list, cob_optarg); break; case CB_FLAG_GETOPT_INCLUDE_FILE: @@ -4038,7 +4038,7 @@ process_command_line (const int argc, char **argv) if (strlen (cob_optarg) > (COB_MINI_MAX)) { cobc_err_exit (COBC_INV_PAR, "--include"); } - CB_TEXT_LIST_ADD (cb_include_file_list, cobc_strdup (cob_optarg)); + CB_TEXT_LIST_ADD (cb_include_file_list, cob_optarg); cb_flag_c_decl_for_static_call = 0; break; diff --git a/tests/testsuite.src/run_misc.at b/tests/testsuite.src/run_misc.at index cd7cf27e6..10df40949 100644 --- a/tests/testsuite.src/run_misc.at +++ b/tests/testsuite.src/run_misc.at @@ -14168,6 +14168,7 @@ AT_KEYWORDS([runmisc CALL bounds exceptions]) # note: this check is likely unportable and therefore will likely be adjusted/skipped, # mainly because the memory layout of consecutive variables is not guaranteed; # it is expected to raise a crash if C bound checking is enabled +AT_SKIP_IF([test $($COBC --info | $GREP -c sanitize) != 0]) AT_DATA([caller.cob], [ IDENTIFICATION DIVISION. From 06d814688dbc4684cd4688ce4d440b8e4699e8c3 Mon Sep 17 00:00:00 2001 From: Simon Sobisch Date: Tue, 10 Dec 2024 08:40:58 +0100 Subject: [PATCH 28/29] Update macos.yml explicit choose ncurses to let the panel library be found (alternative: install ncurses via brew and extend PKG_CONFIG_DIR) --- .github/workflows/macos.yml | 1 + 1 file changed, 1 insertion(+) diff --git a/.github/workflows/macos.yml b/.github/workflows/macos.yml index 3e5e2b8e3..1ae92c8f8 100644 --- a/.github/workflows/macos.yml +++ b/.github/workflows/macos.yml @@ -54,6 +54,7 @@ jobs: cd _build ../configure --enable-cobc-internal-checks \ --enable-hardening \ + --with-curses=ncurses \ --prefix /opt/cobol/gnucobol-gcos \ - name: make From 1c357b4a3894bd09940a01c7ee7e0a5ad90ceeb8 Mon Sep 17 00:00:00 2001 From: ddeclerck Date: Thu, 12 Dec 2024 16:19:57 +0000 Subject: [PATCH 29/29] Fixed [bugs:1032]: app_data field of DBT structure is not always copied when call bdb_bt_compare * libcob/fileio.c: fixed Bug #1032 by always using global thread-static variable bdb_app_data pointer to access the collating sequence function --- libcob/ChangeLog | 5 ++ libcob/fileio.c | 8 +-- tests/testsuite.src/run_file.at | 95 +++++++++++++++++++++++++++++++++ 3 files changed, 105 insertions(+), 3 deletions(-) diff --git a/libcob/ChangeLog b/libcob/ChangeLog index 0c2f7f405..b03c08cb8 100644 --- a/libcob/ChangeLog +++ b/libcob/ChangeLog @@ -1,4 +1,9 @@ +2024-12-11 Emilien Lemaire + + * fileio.c: fixed Bug #1032 by always using global thread-static variable + bdb_app_data pointer to access the collating sequence function + 2024-12-08 Simon Sobisch * screenio.c [WITH_PANELS]: replace use of ncurses extension ceiling_panel() diff --git a/libcob/fileio.c b/libcob/fileio.c index 509623452..df7cc89c2 100644 --- a/libcob/fileio.c +++ b/libcob/fileio.c @@ -690,12 +690,14 @@ static unsigned int bdb_lock_id = 0; key.data = fld->data; \ key.size = (cob_dbtsize_t) fld->size -#if (DB_VERSION_MAJOR > 4) || ((DB_VERSION_MAJOR == 4) && (DB_VERSION_MINOR > 0)) +#if 0 /* while the fields are part of DBT since 4.1, and were made part of the + public API with 6.0 (DB_VERSION_FAMILY 12) this field is not always + copied when passed to custom compare functions, see bug 1032 */ #define DBT_SET_APP_DATA(key,data) ((key)->app_data = (data)) #define DBT_GET_APP_DATA(key) ((key)->app_data) #else -/* Workaround for older BDB versions that do not have app_data in DBT */ -static void *bdb_app_data = NULL; +/* Used to save the collating sequence function */ +COB_TLS void *bdb_app_data = NULL; #define DBT_SET_APP_DATA(key,data) ((void)(key), bdb_app_data = (data)) #define DBT_GET_APP_DATA(key) ((void)(key), bdb_app_data) #endif diff --git a/tests/testsuite.src/run_file.at b/tests/testsuite.src/run_file.at index f7fbbfe8c..0093e1dfe 100644 --- a/tests/testsuite.src/run_file.at +++ b/tests/testsuite.src/run_file.at @@ -14653,3 +14653,98 @@ AT_CHECK([$COBCRUN_DIRECT ./prog2 > prog2.txt]) AT_CHECK([diff expected.txt prog2.txt]) AT_CLEANUP + + +AT_SETUP([DELETE WITH COLLATING SEQUENCE]) +AT_KEYWORDS([runfile WRITE DELETE READ EBCDIC]) + +AT_SKIP_IF([test "$COB_HAS_ISAM" != "db"]) +AT_DATA([prog.cob], [ + IDENTIFICATION DIVISION. + PROGRAM-ID. READDEL. + ENVIRONMENT DIVISION. + CONFIGURATION SECTION. + INPUT-OUTPUT SECTION. + FILE-CONTROL. + + SELECT READDEL ASSIGN EXTERNAL READDEL + ORGANIZATION INDEXED + ACCESS MODE DYNAMIC + RECORD KEY READDEL-KEY + FILE STATUS STA-READDEL. + + DATA DIVISION. + FILE SECTION. + + FD READDEL. + 01 READDEL-REC. + 02 READDEL-KEY. + 05 READDEL-KEY-NUM PIC S9(15). + 02 READDEL-VALUE. + 05 READDEL-STRING PIC X(10). + 05 READDEL-NUM PIC S9(27) OCCURS 10 TIMES. + *> + + *>----------------------* + WORKING-STORAGE SECTION. + *>----------------------* + + 01 STA-READDEL PIC X(2). + 01 END-READDEL PIC 9(1). + 01 WS-COUNT PIC S9(2) VALUE 0. + + *>------------------* + PROCEDURE DIVISION. + *>------------------* + MOVE 0 TO END-READDEL. + OPEN OUTPUT READDEL. + PERFORM 20 TIMES + MOVE WS-COUNT TO READDEL-KEY-NUM + MOVE "READDELNUM" TO READDEL-STRING + MOVE WS-COUNT TO READDEL-NUM(1) + MOVE WS-COUNT TO READDEL-NUM(2) + MOVE WS-COUNT TO READDEL-NUM(3) + MOVE WS-COUNT TO READDEL-NUM(4) + MOVE WS-COUNT TO READDEL-NUM(5) + MOVE WS-COUNT TO READDEL-NUM(6) + MOVE WS-COUNT TO READDEL-NUM(7) + MOVE WS-COUNT TO READDEL-NUM(8) + MOVE WS-COUNT TO READDEL-NUM(9) + MOVE WS-COUNT TO READDEL-NUM(10) + WRITE READDEL-REC + INVALID KEY + DISPLAY "INVALID KEY " READDEL-KEY + STOP RUN + END-WRITE + ADD 1 TO WS-COUNT + END-PERFORM. + CLOSE READDEL. + MOVE LOW-VALUE TO READDEL-KEY. + OPEN I-O READDEL. + START READDEL KEY IS > READDEL-KEY + INVALID KEY + DISPLAY "ERR START READDEL=" STA-READDEL + MOVE 1 TO END-READDEL + END-START. + PERFORM UNTIL END-READDEL = 1 + READ READDEL NEXT RECORD + AT END + MOVE 1 TO END-READDEL + NOT AT END + DELETE READDEL + INVALID KEY + DISPLAY "ERR DELETE KEY=" READDEL-KEY + " / STATUS=" STA-READDEL + END-DELETE + END-READ + END-PERFORM. + CLOSE READDEL. + STOP RUN. + + +]) + +AT_CHECK([$COMPILE -fdefault-file-colseq=EBCDIC prog.cob]) +AT_CHECK([$COBCRUN_DIRECT ./prog]) + +AT_CLEANUP