{****************************************}
{* CPIO: COBOL-Pascal-Input/Output unit *}
{****************************************}

unit cpio;

// Version 1.0, (c) allu, 2025.
// The unit uses the COBOL-Pascal-Strings unit for string I/O.
// Tested with GNU Cobol 3.2 and Lazarus 4.2 (FPC 3.2.2).

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

{$mode ObjFPC}{$H+}

interface

uses
  Crt, cps;

procedure cpio_clear_screen;
procedure cpio_clear_eol;
procedure cpio_clear_lines(Y0, N: Byte); cdecl;
procedure cpio_set_cursor(Y, X: Byte); cdecl;
procedure cpio_write(var CPS0: TCPS); cdecl;
procedure cpio_writeln(var CPS0: TCPS); cdecl;
procedure cpio_readln(var CPS0: TCPS); cdecl;
procedure cpio_color_write(var CPS0: TCPS; FGColor, BGColor: Byte); cdecl;
procedure cpio_color_writeln(var CPS0: TCPS; FGColor, BGColor: Byte); cdecl;
procedure cpio_wait_time(T: Word); cdecl;
procedure cpio_wait_key(Key: Byte); cdecl;
procedure cpio_read_key(var Key, Null: Byte); cdecl;
procedure cpio_get_key(var Key, Null: Byte); cdecl;

implementation

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

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

// The routines using COBOL-Pascal-Strings assume that the maximum and actual length
// are correctly set.
// Please, note that the routines do NOT check the screen related arguments passed!

{ Clear the screen }

procedure cpio_clear_screen;

// The routine clears the Command Prompt window.

begin
  ClrScr;
end;

{ Clear end of line }

procedure cpio_clear_eol;

// The procedure clears the actual line from the cursor position up to the end of the line.

begin
  ClrEoL;
end;

{ Clear one or more lines }

procedure cpio_clear_lines(Y0, N: Byte); cdecl;

// The procedure clears the actual line, plus (if N > 1) the following ones.

var
  Y: Byte;

begin
  for Y := Y0 to Y0 + N - 1 do begin
    GotoXY(1, Y);
    ClrEoL;
  end;
end;

{ Set the cursor position }

procedure cpio_set_cursor(Y, X: Byte); cdecl;

// The procedure sets the cursor at the screen row and column specified.

begin
  GotoXY(X, Y);
end;

{ Text output without CR+LF }

procedure cpio_write(var CPS0: TCPS); cdecl;

// The procedure displays the string item of the COBOL-Pascal-String passed as argument
// at the actual cursor position using the default color settings.
// This procedure does not advance the cursor to the next line.

begin
  cpio_color_write(CPS0, 7, 0);
end;

{ Text output with CR+LF }

procedure cpio_writeln(var CPS0: TCPS); cdecl;

// The procedure displays the string item of the COBOL-Pascal-String passed as argument
// at the actual cursor position using the default color settings.
// This procedure does advance the cursor to the beginning of the next line.

begin
  cpio_color_writeln(CPS0, 7, 0);
end;

{ Colored text output without CR+LF }

procedure cpio_color_write(var CPS0: TCPS; FGColor, BGColor: Byte); cdecl;

// The procedure displays the string item of the COBOL-Pascal-String passed as argument
// at the actual cursor position using the text and background colors specified.
// This procedure does not advance the cursor to the next line.

var
  S0: string;

begin
  TextColor(FGColor);
  TextBackground(BGColor);
  S0 := CPSString2String(CPS0);
  Write(S0);
end;

{ Colored text output with CR+LF }

procedure cpio_color_writeln(var CPS0: TCPS; FGColor, BGColor: Byte); cdecl;

// The procedure displays the string item of the COBOL-Pascal-String passed as argument
// at the actual cursor position using the text and background colors specified.
// This procedure does advance the cursor to the beginning of the next line.

begin
  cpio_color_write(CPS0, FGColor, BGColor);
  Writeln;
end;

{ Text input }

procedure cpio_readln(var CPS0: TCPS); cdecl;

// The procedure reads the text entered from the keyboard into the string item of the
// COBOL-Pascal-String passed as argument.

var
  S0: string;

begin
  Readln(S0);
  CPS0.Len := Length(S0);
  String2CPSString(S0, CPS0);
end;

{ Pause execution for a given time }

procedure cpio_wait_time(T: Word); cdecl;

// The procedure pauses program execution for the number of seconds specified.

begin
  if 1000 * T > 65535 then
    T := 65535;
  Delay(1000 * T);
end;

{ Pause execution until a key has been pressed }

procedure cpio_wait_key(Key: Byte); cdecl;

// The procedure waits until the user presses the key, the ASCII code of which is
// passed as argument. To resume execution for any key pressed, pass the argument 0.

var
  K: Byte;
  Ch: Char;

begin
  K := 255;
  repeat
    repeat
    until KeyPressed;
    Ch := ReadKey; K := Ord(Ch);
    if K = 0 then begin
      Ch := ReadKey; K := Ord(Ch);
    end;
    if (Key <> 0) and (K <> Key) then
      K := 255;
  until K <> 255;
end;

{ Read a key from the keyboard }

procedure cpio_read_key(var Key, Null: Byte); cdecl;

// The procedure waits until the user presses a key on the keyboard, and returns the
// ASCII code of the key pressed. If the key is a special key (defined by a double code,
// a binary 0 and an ASCII value (example: F1 = 0 + 59), the second procedure argument
// is set to 1 (for normal keys, it's set to 0).

var
  Ch: Char;

begin
  Null := 0;
  repeat
  until KeyPressed;
  Ch := ReadKey; Key := Ord(Ch);
  if Key = 0 then begin
    Null := 1;
    Ch := ReadKey; Key := Ord(Ch);
  end;
end;

{ Get the key pressed on the keyboard }

procedure cpio_get_key(var Key, Null: Byte); cdecl;

// The procedure does the same as the preceding one, except that it does not wait for
// user input. In other words, it only returns a key ASCII code if there has been a key
// pressed. If no key was pressed the value of the first argument is set to 255.

var
  Ch: Char;

begin
  Key := 255; Null := 0;
  if KeyPressed then begin
    Ch := ReadKey; Key := Ord(Ch);
    if Key = 0 then begin
      Null := 1;
      Ch := ReadKey; Key := Ord(Ch);
    end;
  end;
end;

end.