Programmer 7500/MAX_PROGRAMMERS.iso/PASCAL/EM3270.ZIP/EM3270.INC

Text File | 1986-07-13 | 15.5 KB | 601 lines

{  EM3270: Turbo Pascal routines for IBM 3270 emulation.  }
{  Copyright 1984, 85, 86 Piedmont Specialty Software.    }
{                                                         }
{           Version 2.03 July, 1986                       }
{                                                         }
{  Distributed as "User supported software." Anyone       }
{  finding these routines useful is requested to send     }
{  $20.00 to:                                             }
{                                                         }
{          Piedmont Specialty Software                    }
{          P. O. Box 6637                                 }
{          Macon, GA  31208                               }
{                                                         }
{  This fee entitles you to unrestricted personal use     }
{  of EM3270 and product updates when available.          }
{                                                         }
{  Commercial licenses are available. Contact PSS at the  }
{  address above or call [phone] for details.      }
{                                                         }
{  This software may be freely distributed as long as     }
{  the accompanying documentation and demonstration       }
{  program are included, as well as this notice.          }

Const
  Modified         = 16;
  Invisible        = 32;
  Blinking         = 64;
  Dim              = 128;

Type
  FieldPtrs  = ^FieldRcd;
  FieldRcd   = Record
                 XPos           : Byte;
                 YPos           : Byte;
                 Attribute      : Byte;
                 FieldLength    : Byte;
                 FieldValue     : String[80]
               End;
  PtrArray   = Array[1..MaxFields] of FieldPtrs;
  ScreenLine = String[80];
  AID        = (Enter,Escape,F1,F2,F3,F4,F5,F6,F7,F8,F9,F10,
                F11,F12,F13,F14,F15,F16,F17,F18,F19,F20,PA1,PA2,PA3);
  CursInfo   = Record
                 Field : Byte;
                 Char  : Byte;
                 X     : Byte;
                 Y     : Byte;
               End;

Var
  ScreenField : PtrArray;
  LastField   : Byte;
  ColorScreen : Boolean;
  Cursor      : CursInfo;
  BrightBG,
  BrightFG,
  DimBG,
  DimFG       : Byte;

    {***************************}
    {*  Initialize everything  *}
    {***************************}

Procedure InitScreen;

Type
  RegRec = Record
             AX,BX,CX,DX,BP,SI,DI,ES,Flags : Integer;
           End;

Var
  I : Integer;
  Regs : RegRec;

Begin
For I := 1 to MaxFields do ScreenField[I] := Nil;
Intr ($11, Regs);
Case Lo(Regs.AX) and $30 of
  $10 : Begin
        TextMode (C80);
        ColorScreen := True;
        End;
  $20 : ColorScreen := True;
  $30 : ColorScreen := False;
Else
  Begin
  ClrScr;
  WriteLn ('THIS PROGRAM MUST HAVE AN');
  WriteLn ('80-COLUMN SCREEN, COLOR OR');
  WriteLn ('MONOCHROME, TO RUN PROPERLY.'); WriteLn;
  WriteLn ('USE THE COMMAND'); WriteLn;
  WriteLn ('     MODE CO80     (color)');
  WriteLn ('or');
  WriteLn ('     MODE MONO     (mono)'); WriteLn;
  WriteLn ('AND TRY THIS PROGRAM AGAIN.');
  Halt;
  End;
  End; {of case}
DimBG := Black; DimFG := LightGray;
BrightBG := LightGray; BrightFG := Black;
End;

    {*******************************************}
    {*  Set video mode specified by attribute  *}
    {*******************************************}

Procedure NormVid (At:Byte);
Var I,J : Byte;
Begin
If (At and Blinking) <> 0 then I := 16 else I := 0;
If ColorScreen Then
  Begin
  J := At and 15;
  If J = 0 then J := BrightFG;
  TextColor (J+I);
  TextBackground (BrightBG);
  End
Else
  Begin
  TextColor (Black+I);
  TextBackground (LightGray);
  End;
End;

Procedure LowVid (At:Byte);
Var I,J : Byte;
Begin
If (At and Blinking) <> 0 then I := 16 else I := 0;
If ColorScreen Then
  Begin
  J := At and 15;
  If J = 0 then J := DimFG;
  TextColor (J+I);
  TextBackground (DimBG);
  End
Else
  Begin
  TextColor (LightGray+I);
  TextBackground (Black);
  End;
End;

Procedure SetVid (At:Byte);
Begin
If (At and Dim) <> 0 then LowVid(At) else NormVid(At);
End;

    {******************************}
    {*  Adjust length of and pad  *}
    {*  a string with blanks      *}
    {******************************}

Procedure Adjust (Var Strng:ScreenLine; Lngth:Byte);
Var I : Integer;
Begin
If Length(Strng) < Lngth Then
  Begin
  I := Length(Strng) + 1;
  FillChar (Strng[I], 81-I, ' ');
  End;
Strng[0] := Chr(Lngth);
End;

    {*******************************}
    {*  Convert 3270 attribute to  *}
    {*  PC hardware attribute      *}
    {*******************************}

Procedure ConvAttr (Var InAt,OutAt:Byte);
Var
  I : Byte;
Begin
I := InAt and $0F;
If (InAt and Dim) = 0 Then
  If ColorScreen Then
    Begin
    If I = 0 then OutAt := BrightFG else OutAt := I;
    OutAt := OutAt or (BrightBG and 7) shl 4;
    End
  Else
    OutAt := $70
Else
  If ColorScreen Then
    Begin
    If I = 0 then OutAt := DimFG else OutAt := I;
    OutAt := OutAt or (DimBG and 7) shl 4;
    End
  Else
    OutAt := $07;
If (InAt and Blinking) <> 0 then OutAt := OutAt + 128;
End;

    {******************************}
    {*  Prepare for a new screen  *}
    {******************************}

Procedure NewScreen;

Var
  I : Integer;

Begin
LowVid(0);
ClrScr;
I := 1;
While (I <= MaxFields) and (ScreenField[I] <> Nil) do
  Begin
  Dispose(ScreenField[I]);
  ScreenField[I] := Nil;
  I := I + 1;
  End;
LastField := 0;
End;

    {***************************************}
    {*  Write a string to the screen fast  *}
    {***************************************}

Procedure PutLine (X,Y,Attr:byte; Var StringIn:ScreenLine);
Begin
   Inline($1E/$8A/$86/Y/$FE/$C8/$B3/$50/$F6/$E3/$2B/$DB/$8A/$9E/X/$FE/$CB/$03/
          $C3/$03/$C0/$8B/$F8/$8A/$BE/Attr/$C4/$B6/StringIn/$2B/$C9/$26/$8A/
          $0C/$A0/ColorScreen/$22/$C9/$74/$34/$20/$C0/$74/$21/$BA/$00/$B8/$8E/
          $DA/$BA/$DA/$03/$46/$26/$8A/$1C/$EC/$A8/$01/$75/$FB/$FA/$EC/$A8/$01/
          $74/$FB/$89/$1D/$47/$47/$E2/$EB/$2A/$C0/$74/$0F/$BA/$00/$B0/$8E/$DA/
          $46/$26/$8A/$1C/$89/$1D/$47/$47/$E2/$F6/$1F);
End;

    {****************************************}
    {*  Write a prompt field to the screen  *}
    {****************************************}

Procedure WritePrompt(X,Y,Attr,Lngth:Byte; Stringin:ScreenLine);

Var
  I        : Byte;
  Strng    : ScreenLine;
  HdwAt    : Byte;

Begin
Strng := Stringin;
Adjust (Strng, Lngth);
ConvAttr (Attr, HdwAt);
PutLine (X, Y, HdwAt, Strng);
End;

    {***********************************}
    {*  Rewrite a field to the screen  *}
    {***********************************}

Procedure RewriteField(FieldNo:Byte; Stringin:ScreenLine; Attr:Byte);

Var
  I     : Byte;
  Strng : ScreenLine;
  HdwAt : Byte;
  X, Y  : Byte;

Begin
Strng := Stringin;
With ScreenField[FieldNo]^ do
  Begin
  Adjust (Strng, FieldLength);
  Attribute := Attr;
  FieldValue := Strng;
  X := XPos;
  Y := YPos;
  End;
If (Attr and Invisible) <> 0 then FillChar (Strng[1], Length(Strng), ' ');
ConvAttr (Attr, HdwAt);
PutLine (X, Y, HdwAt, Strng);
End;

    {******************************************}
    {*  Write a new data field to the screen  *}
    {******************************************}

Procedure WriteField(X,Y,Attr,Lngth:Byte; Stringin:ScreenLine);

Var
  I                : Byte;
  Strng            : ScreenLine;

Begin
Strng := Stringin;
Adjust (Strng, Lngth);
LastField := LastField + 1;
New(ScreenField[LastField]);
With ScreenField[LastField]^ do
  Begin
  XPos := X;
  YPos := Y;
  FieldLength := Lngth;
  End;
RewriteField (LastField, Strng, Attr);
End;

    {*****************************}
    {*  Get input from keyboard  *}
    {*****************************}

Procedure ReadScreen(FieldNo:Byte;Var FuncKey:AID);

Const
  EntCd = #128;  EscCd = #129;

  F1Cd = #130;   F2Cd = #131;   F3Cd = #132;   F4Cd = #133;   F5Cd = #134;
  F6Cd = #135;   F7Cd = #136;   F8Cd = #137;   F9Cd = #138;   F10Cd = #139;
  F11Cd = #140;  F12Cd = #141;  F13Cd = #142;  F14Cd = #143;  F15Cd = #144;
  F16Cd = #145;  F17Cd = #146;  F18Cd = #147;  F19Cd = #148;  F20Cd = #149;

  PA1Cd = #150;  PA2Cd = #151;  PA3Cd = #152;

  LeftArrow = #153;  RightArrow = #154;  Insert = #155;    Delete = #156;
  EraseEOF = #157;   TabRight = #159;    TabLeft = #160;   NewLine = #161;
  Home = #162;

    {*  Position the cursor  *}

Procedure PutCursorIn(FieldNo:Byte; Var X,Y:Byte);

Begin
With ScreenField[FieldNo]^ do
  Begin
  X := XPos;
  Y := YPos;
  SetVid (Attribute);
  End;
GotoXY(X,Y);
End;

    {*  Tab one field forward  *}

Procedure TabFwd(Var FieldNo:Byte);

Begin
If FieldNo >= LastField Then
  FieldNo := 1
Else
  FieldNo := FieldNo + 1;
End;

    {*  Tab one field backward  *}

Procedure TabBack(Var FieldNo:Byte);

Begin
If FieldNo = 1 Then
  FieldNo := LastField
Else
  FieldNo := FieldNo - 1;
End;

    {*  Tab one line down  *}

Procedure TabDown(Var FieldNo:Byte);

Var Y : Byte;

Begin
  Y := ScreenField[FieldNo]^.YPos;
  Repeat TabFwd(FieldNo) until (ScreenField[FieldNo]^.YPos<>Y) or (FieldNo=1);
End;

    {*  Display a character  *}

Procedure DC(Ch:Char; At:Byte);

Begin
  If (At and Invisible) = 0 Then Write(Ch) Else Write(' ');
End;

    {*  Get a character from the keyboard *}

Procedure GetChar (Var Ch:Char);

Var
  OK, Esc          : Boolean;

Begin
Repeat
  Esc := False;
  Read (Kbd, Ch);
  If Ch = #27 Then
    Begin
      Esc := True;
      If KeyPressed then Read (Kbd, Ch);
    End;
  If (Esc) or (Ch < ' ') Then
    Begin
      OK := True;
      Case Ch of
        'K'      : Ch := LeftArrow;
        'M'      : Ch := RightArrow;
        'R'      : Ch := Insert;
        'S'      : Ch := Delete;
        ^I       : Ch := TabRight;
        ^H,^O    : Ch := TabLeft;
        #79      : Ch := EraseEOF;
        'Q'      : Ch := NewLine;
        'G'      : Ch := Home;
        #27      : Ch := EscCd;
        ^M       : Ch := EntCd;
        ';'      : Ch := F1Cd;
        '<'      : Ch := F2Cd;
        '='      : Ch := F3Cd;
        '>'      : Ch := F4Cd;
        '?'      : Ch := F5Cd;
        '@'      : Ch := F6Cd;
        'A'      : Ch := F7Cd;
        'B'      : Ch := F8Cd;
        'C'      : Ch := F9Cd;
        'D'      : Ch := F10Cd;
        'h'      : Ch := F11Cd;
        'i'      : Ch := F12Cd;
        'j'      : Ch := F13Cd;
        'k'      : Ch := F14Cd;
        'l'      : Ch := F15Cd;
        'm'      : Ch := F16Cd;
        'n'      : Ch := F17Cd;
        'o'      : Ch := F18Cd;
        'p'      : Ch := F19Cd;
        'q'      : Ch := F20Cd;
        'x'      : Ch := PA1Cd;
        'y'      : Ch := PA2Cd;
        'z'      : Ch := PA3Cd;

      Else
        OK := False;
      End;
    End
  Else
    If Ch in [ ' '..'~'] then OK := True else Ok := False;
Until OK;
End;

Var
  X,Y,I,J,K,MDT   : Byte;
  InsertMode,
  InThisField     : Boolean;
  InpChar         : Char;

Begin
InsertMode := False;
Repeat
  PutCursorIn(FieldNo,X,Y);
  InThisField := True;
  MDT := 0;
  I := 1;
  J := FieldNo;
  SetVid (ScreenField[FieldNo]^.Attribute);
  While InThisField do
    With ScreenField[FieldNo]^ do
      Begin
      GetChar (InpChar);
      If InpChar in [' '..'~'] Then
        Begin
        If InsertMode Then
          If (FieldValue[FieldLength] <> ' ') or (I = FieldLength) Then
            Begin
            Write(^G);
            InpChar := #0;
            End
          Else
            Begin
            For K := FieldLength downto I+1 do
              FieldValue[K] := FieldValue[K-1];
            Write(' ');
            For K := I+1 to FieldLength do DC(FieldValue[K], Attribute);
            GotoXY(X,Y);
            End;
        If InpChar <> #0 Then
          Begin
          DC(InpChar, Attribute);
          FieldValue[I] := InpChar;
          MDT := Modified;
          I := I + 1;
          X := X + 1;
          If I > FieldLength Then
            Begin
            TabFwd(FieldNo);
            InThisField := False;
            End;
          End
        End
      Else
        Case InpChar of

          RightArrow : Begin
                       I := I + 1;
                       X := X + 1;
                       If I <= FieldLength Then
                         GotoXY(X,Y)
                       Else
                         Begin
                         TabFwd(FieldNo);
                         InThisField := False;
                         End;
                      End;

          LeftArrow : Begin
                      I := I - 1;
                      X := X - 1;
                      If I > 0 Then
                        GotoXY(X,Y)
                      Else
                        Begin
                        TabBack(FieldNo);
                        InThisField := False;
                        End;
                      End;


          TabRight  : Begin
                      TabFwd(FieldNo);
                      InThisField := False
                      End;

          NewLine   : Begin
                      TabDown(FieldNo);
                      InThisField := False;
                      End;

          TabLeft   : Begin
                      TabBack(FieldNo);
                      InThisField := False;
                      End;

          Home     : Begin
                     FieldNo := 1;
                     InThisField := False;
                     End;

          EraseEOF : Begin
                     For K := I to FieldLength do
                       Begin
                       Write(' ');
                       FieldValue[K] := ' ';
                       End;
                       GotoXY(X,Y);
                     End;

          Delete    : Begin
                      If I < FieldLength Then
                        Begin
                        For J := I to FieldLength - 1 do
                          Begin
                          FieldValue[J] := FieldValue[J+1];
                          DC(FieldValue[J], Attribute);
                          End;
                        End;
                      FieldValue[FieldLength] := ' ';
                      Write(' ');
                      GotoXY(X,Y);
                      End;

          Insert    : Begin
                      InsertMode := Not InsertMode;
                      GotoXY(77,25);
                      LowVid(0);
                      If InsertMode Then Write('INS') Else Write('   ');
                      GotoXY(X,Y);
                      SetVid (Attribute);
                      End;

          EntCd..PA3Cd : Begin
                         InThisField := False;
                         FuncKey := AID(Ord(InpChar) - 128);
                         End;

          End; {of Case}
      End;     {of With (and While)}
  If MDT = Modified Then
    With ScreenField[J]^ do Attribute := Attribute or MDT;
Until InpChar in [EntCd..PA3Cd];   {end of Repeat}
Cursor.Field := FieldNo;
Cursor.Char := I;
Cursor.X := X;
Cursor.Y := Y;
GotoXY (77,25);
LowVid(0);
Write ('   ');
End;           {of Procedure ReadScreen}

    {**************************************}
    {*  Get a field back from the screen  *}
    {**************************************}

Procedure GetField(FieldNo:Byte; Var Strng:ScreenLine; Var Attr:Byte);

Var
  I : Byte;

Begin
With ScreenField[FieldNo]^ do
  Begin
  Attr := Attribute;
  Strng := FieldValue;
  End;
End;