:cat cstCblStr.pas {$mode objfpc}{$H+} library cstCblStr; uses math, sysutils; type aocT = array of char; cstSTringT = record max : word; len : word; str : array [word] of char; // str can contain up to 65K bytes. end; // cstStringT // ***** Forward Decls ******************************************************** // ---------------------------------------------------------------------------- // cstdeb: // Given a string, remove all leading and trailing spaces. procedure cstdeb( var cst : cstStringT ); cdecl; forward; // ---------------------------------------------------------------------------- // cstrightj: // Given a string, and a length, right justify within that length. If // length is < actual string length, string will truncate on the left to fit. procedure cstrightj( var cst : cstStringT; var n : smallint ); cdecl; forward; // ---------------------------------------------------------------------------- // cstset: // Given a string and a buffer, initialized the string with the contents // of the buffer, setting len to last non-space character in buffer. procedure cstset( var cstString : cstStringT; var buf : aocT; var buflen : smallint ); cdecl; forward; exports cstdeb, cstrightj, cstset; function cst2str( var cst : cstStringT ) : string; forward; procedure str2cst( s : string; var cst : cstStringT ); forward; // ***** Exported Routines **************************************************** procedure cstdeb( var cst : cstStringT ); cdecl; var s : string; begin //writeln('@cstdeb. cst:'); //memdump(@cst, 4+cst.len); s := cst2str(cst); s := trimleft(trimright(s)); str2cst(s, cst); //writeln(' after. cst:'); //memdump(@cst, 4+cst.len); end; // cstdeb // ---------------------------------------------------------------------------- procedure cstrightj( var cst : cstStringT; var n : smallint ); cdecl; var s : string; begin with cst do begin if (max = 0) or (len = 0) then exit; if n > max then n := max; //writeln('@cstjustr. cst:'); //memdump(@cst, 4+cst.len); s := cst2str(cst); s := trimleft(trimright(s)); // remove all trailing and leading spaces if length(s) >= n then // if string already fills area available, fill that area. s := copy(s, length(s) - n + 1, n) else // else insert leading spaces s := concat(stringOfChar(' ', n - length(s)), s); str2cst(s, cst); //writeln(' after. cst:'); //memdump(@cst, 4+cst.len); end; //with end; // cstrightj // ---------------------------------------------------------------------------- procedure cstset( var cstString : cstStringT; var buf : aocT; var buflen : smallint ); cdecl; begin with cstSTring do begin if (max = 0) then begin // handle bad maxSize with len:= 0; len := 0; exit; end; fillchar(str, max, ' '); // prefill str-out with spaces move(buf, str, min(buflen,max)); // copy buf to str-out not to exceed str's max size len := max; while (len > 0) and (str[len-1] = ' ') do begin // look for first non-trailing space. that is the length of the string. len := len - 1; end; end; // with end; // cstset // ***** Internal Routines **************************************************** function cst2str( var cst : cstStringT ) : string; var i : smallint; begin with cst do begin result := ''; if (max = 0) or (len = 0) or (len > max) then exit; i := 0; while (i < len) and (ord(str[i]) <> 0) do begin result := result + str[i]; i := i + 1; end; // while end; // with end; // cst2str // ---------------------------------------------------------------------------- procedure str2cst( s : string; var cst : cstStringT ); begin with cst do begin fillchar(str, max, ' '); // prefill str-out with spaces len := min(length(s), max); move(s[1], str[0], len); // copy buf to str-out not to exceed str's max size end; // with end; // str2cst end. : :fpc cstCblStr.pas Free Pascal Compiler version 3.0.4 [2019/04/13] for i386 Copyright (c) 1993-2017 by Florian Klaempfl and others Target OS: Win32 for i386 Compiling cstCblStr.pas Linking cstCblStr.dll 213 lines compiled, 0.1 sec, 64688 bytes code, 4132 bytes data : :export COB_PRE_LOAD=cstCblStr.dll : :cobc -L. -l:cstCblStr.dll -t cstTest.lst -xj cstTest.cbl buf: >test string < After cfCstSet, cst-out: >test string< After cfCstDeb, cst-out: >hello world< After cfCstRightJ, cst-out: > Text to right justify.< : :cat cstTest.lst GnuCOBOL 3.1-rc1.0 cstTest.cbl Tue Aug 18 11:33:28 2020 Page 0001 LINE PG/LN A...B............................................................ 000001 >>SOURCE FREE 000002 identification division. 000003 program-id. 000004 cstTest. 000005 000006 data division. 000007 working-storage section. 000008 000009 copy wscst. 000001C >>SOURCE FREE 000002C *>wscst: 000003C *> AA0000: 01/08/88: 000004C *> STR COBOL string routine data names. 000005C *> AA0001: 01/31/12: 000006C *> Converted to run in OpenCobol. 000007C 000008C *>-------------------------------------------------------------- 000009C *> COPY wscst 000010C *> [REPLACING 256 BY ]. 000011C *>-------------------------------------------------------------- 000012C 000013C *> STANDARD COBOL STRING DATA STRUCTURE. 000014C *> You can change the maximum string size by using the 000015C *> REPLACING clause. 000016C 000017C 01 cst-string. 000018C 03 cst-max binary-short unsigned, value 256 000018+ . 000019C 03 cst-len binary-short unsigned. 000020C 03 cst-out. 000021C 05 cst-byte pic x, 000022C occurs 0 to 256 times, 000023C depending on cst-len. 000024C 000010 000011 01 buf pic x(40). 000012 000013 procedure division. 000014 000015 *> ***** cstSet test 000016 000017 move "test string" to buf. 000018 display "buf: >", buf, "<". 000019 000020 copy cfCstSet, replacing cst-in by buf. 000001C >>source free 000002C *>cfCstSet: 000003C *> 01/31/12: 000004C *> Created for openCOBOL. 000005C *> 08/15/20: 000006C *> Updated for gnuCOBOL. 000007C GnuCOBOL 3.1-rc1.0 cstTest.cbl Tue Aug 18 11:33:28 2020 Page 0002 LINE PG/LN A...B............................................................ 000008C *>-------------------------------------------------------------- 000009C *> COPY cfstrset 000010C *> REPLACING cst-in BY ]. 000011C *>-------------------------------------------------------------- 000012C 000013C *> openCOBOL doesn't allow my old STR string structure. The new 000014C *> structure requires the following code frag to move something 000015C *> into the structure and set the size. 000016C 000017C *> This code fragment can be copied anywhere such as: 000018C *> if 1=1 then 000019C *> copy cfCstSet replacing cst-in with "test"; 000020C *> else, 000021C *> next sentence. 000022C 000023C call "cstset" 000024C using cst-string, 000025C buf, 000026C function byte-length(cst-in); 000021 display "After cfCstSet, cst-out: >", cst-out, "<". 000022 000023 *> ***** cstdeb test 000024 000025 copy cfCstSet, replacing cst-in by " hello world ". 000001C >>source free 000002C *>cfCstSet: 000003C *> 01/31/12: 000004C *> Created for openCOBOL. 000005C *> 08/15/20: 000006C *> Updated for gnuCOBOL. 000007C 000008C *>-------------------------------------------------------------- 000009C *> COPY cfstrset 000010C *> REPLACING cst-in BY ]. 000011C *>-------------------------------------------------------------- 000012C 000013C *> openCOBOL doesn't allow my old STR string structure. The new 000014C *> structure requires the following code frag to move something 000015C *> into the structure and set the size. 000016C 000017C *> This code fragment can be copied anywhere such as: 000018C *> if 1=1 then 000019C *> copy cfCstSet replacing cst-in with "test"; 000020C *> else, 000021C *> next sentence. 000022C 000023C call "cstset" 000024C using cst-string, 000025C " hello world ", 000026C function byte-length(cst-in); 000026 copy cfCstdeb. 000001C >>source free GnuCOBOL 3.1-rc1.0 cstTest.cbl Tue Aug 18 11:33:28 2020 Page 0003 LINE PG/LN A...B............................................................ 000002C *>cfCstSet: 000003C 000004C *> Code Fragment to call cstdeb to deblank [(ltrim(rtrim(s))] cst-strin 000004+ g. 000005C 000006C *>-------------------------------------------------------------- 000007C *> COPY cfstrdeb. 000008C *>-------------------------------------------------------------- 000009C 000010C call "cstdeb" 000011C using cst-string; 000027 display "After cfCstDeb, cst-out: >", cst-out, "<". 000028 000029 *> ***** right just test 000030 000031 copy cfCstSet, replacing cst-in by "Text to right justify.". 000001C >>source free 000002C *>cfCstSet: 000003C *> 01/31/12: 000004C *> Created for openCOBOL. 000005C *> 08/15/20: 000006C *> Updated for gnuCOBOL. 000007C 000008C *>-------------------------------------------------------------- 000009C *> COPY cfstrset 000010C *> REPLACING cst-in BY ]. 000011C *>-------------------------------------------------------------- 000012C 000013C *> openCOBOL doesn't allow my old STR string structure. The new 000014C *> structure requires the following code frag to move something 000015C *> into the structure and set the size. 000016C 000017C *> This code fragment can be copied anywhere such as: 000018C *> if 1=1 then 000019C *> copy cfCstSet replacing cst-in with "test"; 000020C *> else, 000021C *> next sentence. 000022C 000023C call "cstset" 000024C using cst-string, 000025C "Text to right justify.", 000026C function byte-length(cst-in); 000032 copy cfCstRightJ, replacing cst-max by 30. 000001C >>source free 000002C *>cfCstRightJ: 000003C 000004C *> Code Fragment to call cstrightj to right justify cst-string. 000005C 000006C *>-------------------------------------------------------------- 000007C *> COPY cfstrrightj[, 000008C *> replacing cst-max by ]. 000009C *>-------------------------------------------------------------- GnuCOBOL 3.1-rc1.0 cstTest.cbl Tue Aug 18 11:33:28 2020 Page 0004 LINE PG/LN A...B............................................................ 000010C 000011C call "cstrightj" 000012C using cst-string, 000013C 30. 000014C 000033 display "After cfCstRightJ, cst-out: >", cst-out, "<". 000034 000035 stop run. 0 warnings in compilation group 0 errors in compilation group :