{**********************************}
{* CPS: COBOL-Pascal-Strings unit *}
{**********************************}

unit cps;

// Version 1.0, (c) allu, 2025.
// Support for ASCII (ANSI) characters only.
// Tested with GNU Cobol 3.2 and Lazarus 4.2 (FPC 3.2.2).

// Include this unit into your Pascal library, and export
// the functions/procedures that you want to call from COBOL.

{$mode ObjFPC}{$H+}

interface

uses
  SysUtils;

type
  // COBOL-Pascal-String type declaration
  TCPS = record
    MaxLen: Word;                                                              // maximum length of the string
    Len: Word;                                                                 // actual length of the string
    Str: array[Word] of Char;                                                  // the string itself
  end;

function  cps_length(var CPS0: TCPS): Word; cdecl;
procedure cps_trim(var CPS0: TCPS); cdecl;
procedure cps_fill(var CPS0: TCPS; var Ch: Char); cdecl;
procedure cps_concat(var CPS0, CPS1: TCPS; var Ch: Char); cdecl;
procedure cps_substr(var CPS0: TCPS; P, L: Word); cdecl;
procedure cps_delete(var CPS0: TCPS; P, L: Word); cdecl;
procedure cps_insert(var CPS0, CPS1: TCPS; P: Word); cdecl;
function  cps_find(var CPS0, CPS1: TCPS): Word; cdecl;
procedure cps_replace(var CPS0, CPS1, CPS2: TCPS; RepFlagAll: Byte = 1); cdecl;
procedure cps_uppercase(var CPS0: TCPS); cdecl;
procedure cps_lowercase(var CPS0: TCPS); cdecl;
function  CPSString2String(var CPS0: TCPS): string;
procedure String2CPSString(S: string; var CPS0: TCPS);

implementation

{ ================= }
{ Internal routines }
{ ================= }

// These routines are called by all other routines of the unit to do the conversion between
// COBOL-Pascal-Strings and regular Pascal strings. COBOL-Pascal-Strings with length set to
// 0 and empty Pascal strings are not supported and make the program abort!

{ Convert a COBOL-Pascal-String to a regular Pascal string }

function CPSString2String(var CPS0: TCPS): string;

// The function makes the program abort if the maximum or actual string length are
// set to 0, or if the actual string length has a value greater than the maximum length.

var
  I: Word;
  S: string;

begin
  with CPS0 do begin
    if (MaxLen = 0) or (Len = 0) or (Len > MaxLen) then begin
      Writeln('Invalid Cobol-Pascal-String!');
      Halt;
    end;
    S := '';
    for I := 0 to Len - 1 do
      S += Str[I];
  end;
  Result := S;
end;

{ Convert a Pascal string to a COBOL-Pascal-String }

procedure String2CPSString(S: string; var CPS0: TCPS);

// The function makes the program abort if the maximum length of the
// COBOL-Pascal-String is set to 0, or if the Pascal string is an empty string.
// If the length of the Pascal string exceeds the maximum length value of the
// COBOL-Pascal-String, the string will be truncated.

begin
  with CPS0 do begin
    if MaxLen = 0 then begin
      Writeln('Invalid Cobol-Pascal-String!');
      Halt;
    end;
    if Length(S) = 0 then begin
      Writeln('Empty Pascal strings are not supported!');
      Halt;
    end;
    FillChar(Str, MaxLen, ' ');
    if Length(S) <= MaxLen then
      Len := Length(S)
    else
      Len := MaxLen;
    Move(S[1], Str[0], Len);
  end;
end;

{ =============== }
{ Public routines }
{ =============== }

// These routines may be called by COBOL programs.
// Do not forget to export the routines that you actually use, in your Pascal library!

// All routines assume that the maximum length of the COBOL-Pascal-String is correctly
// set. Except for "cps_length" and "cps_trim", the actual length has also to be correct.

{ Get the length of a COBOL-Pascal-String }

function  cps_length(var CPS0: TCPS): Word; cdecl;

// The function returns the length of the string item of the COBOL-Pascal-String
// without the trailing spaces. This is a convenient way to determine the "real"
// length of a COBOL-Pascal-String.

var
  S0: string;

begin
  CPS0.Len := CPS0.MaxLen;
  S0 := TrimRight(CPSString2String(CPS0));
  Result := Length(S0);
end;

{ Right-trim a COBOL-Pascal-String }

procedure cps_trim(var CPS0: TCPS); cdecl;

// The procedure cuts of the trailing spaces of of the string item of the COBOL-Pascal-String.
// The actual string length value is set accordingly by the procedure.

var
  S0: string;

begin
  CPS0.Len := CPS0.MaxLen;
  S0 := TrimRight(CPSString2String(CPS0));
  CPS0.Len := Length(S0);
  String2CPSString(S0, CPS0);
end;

{ Fill a COBOL-Pascal-String with a given character }

procedure cps_fill(var CPS0: TCPS; var Ch: Char); cdecl;

// The procedure fills the string item of a COBOL-Pascal-String with a given
// character. The number of characters included in the string, will be the
// value set as actual COBOL-Pascal-String length.

var
  I: Integer;
  S0: string;

begin
  S0 := '';
  for I := 1 to CPS0.Len do
    S0 += Ch;
  String2CPSString(S0, CPS0);
end;

{ Concatenate two COBOL-Pascal-Strings }

procedure cps_concat(var CPS0, CPS1: TCPS; var Ch: Char); cdecl;

// The procedure concatenates two COBOL-Pascal-Strings, the resulting
// string being stored into the first argument of the procedure call.
// The character, specified as third procedure argument is inserted as
// separator between the two strings, except for X'00'; in this case the
// strings are concatenated without separator.

var
  S0: string;

begin
  S0 := cpsstring2string(CPS0);
  if Ch <> #00 then
    S0 += Ch;
  S0 += cpsstring2string(CPS1);
  String2CPSString(S0, CPS0);
end;

{ Extract a substring from a COBOL-Pascal-String }

procedure cps_substr(var CPS0: TCPS; P, L: Word); cdecl;

// The procedure extracts a substring starting at position P and of length L
// from a COBOL-Pascal-String. The substring will be stored replacing the content
// of the first procedure argument.
// The procedure makes the program abort if P or L are invalid.
// If P + L exceeds the actual length of the COBOL-Pascal-String, the result will
// be the substring starting at P and up to the end of the original string.

var
  S0: string;

begin
  if (P < 1) or (L < 1) or (P > CPS0.Len) then begin
    Writeln('Invalid substring parameters!');
    Halt;
  end;
  S0 := Copy(cpsstring2string(CPS0), P, L);
  String2CPSString(S0, CPS0);
end;

{ Delete a part of a COBOL-Pascal-String }

procedure cps_delete(var CPS0: TCPS; P, L: Word); cdecl;

// The procedure deletes the part of the string starting at position P and of length L
// from a COBOL-Pascal-String. The new string will be stored replacing the content of
// the first procedure argument.
// The procedure makes the program abort if P or L are invalid.
// If P + L exceeds the actual length of the COBOL-Pascal-String, the result will be a
// string with the part, starting at P and up to the end of the original string, deleted.

var
  S0: string;

begin
  S0 := cpsstring2string(CPS0);
  if (P < 1) or (L < 1) or (P > CPS0.Len) then begin
    Writeln('Invalid deletion parameters');
    Halt;
  end;
  Delete(S0, P, L);
  String2CPSString(S0, CPS0);
end;

{ Insert a COBOL-Pascal-String into a COBOL-Pascal-String }

procedure cps_insert(var CPS0, CPS1: TCPS; P: Word); cdecl;

// The procedure inserts the second procedure argument at position P of the first argument.
// The procedure makes the program abort if P or L are invalid, or if the new string exceeds
// the maximum length of the first argument COBOL-Pascal-String.

var
  S0, S1: string;

begin
  S0 := cpsstring2string(CPS0);
  S1 := cpsstring2string(CPS1);
  if (P < 1) or (P > CPS0.Len) or (Length(S0) + Length(S1) > CPS0.MaxLen) then begin
    Writeln('Invalid insertion parameters');
    Halt;
  end;
  Insert(S1, S0, P);
  String2CPSString(S0, CPS0);
end;

{ Find a substring in a COBOL-Pascal-String }

function cps_find(var CPS0, CPS1: TCPS): Word; cdecl;

// The function searches for the first occurrence of the second procedure argument
// within the first argument COBOL-Pascal-String and returns its position.

var
  S0, S1: string;

begin
  S0 := CPSString2String(CPS0);
  S1 := CPSString2String(CPS1);
  Result := Pos(S1, S0);
end;

{ Replace a substring of a COBOL-Pascal-String by another }

procedure cps_replace(var CPS0, CPS1, CPS2: TCPS; RepFlagAll: Byte = 1); cdecl;

// The procedure replaces the first, or all occurrences of the second procedure argument
// within the first argument COBOL-Pascal-String by the third argument.
// The fourth argument of the procedure is an optional flag; if set to a value <> 0 (default),
// all occurrences of the string are replaced; if set to 0, only the first occurrence is replaced.

var
  S0, S1, S2: string;

begin
  S0 := CPSString2String(CPS0);
  S1 := CPSString2String(CPS1);
  S2 := CPSString2String(CPS2);
  if RepFlagAll = 0 then
    S0 := StringReplace(S0, S1, S2, [])
  else
    S0 := StringReplace(S0, S1, S2, [rfReplaceAll]);
  String2CPSString(S0, CPS0);
end;

{ Covert a COBOL-Pascal-String to uppercase }

procedure cps_uppercase(var CPS0: TCPS); cdecl;

// The string item of the COBOL-Pascal-String argument is converted to uppercase.

var
  S0: string;

begin
  S0 := UpperCase(CPSString2String(CPS0));
  String2CPSString(S0, CPS0);
end;

{ Covert a COBOL-Pascal-String to lowercase }

procedure cps_lowercase(var CPS0: TCPS); cdecl;

// The string item of the COBOL-Pascal-String argument is converted to lowercase.

var
  S0: string;

begin
  S0 := LowerCase(CPSString2String(CPS0));
  String2CPSString(S0, CPS0);
end;

end.