Programmer 7500/MAX_PROGRAMMERS.iso/PASCAL/BAKLPT.ZIP/BAKLPT.PAS

Pascal/Delphi Source File | 1988-08-03 | 12.4 KB | 425 lines

{$R-,S-,I-,D+,V-}
{
  ** BakLPT Unit **
  ** by Richard S. Sadowsky      CIS [74017,1670]
  ** 8/3/88
  ** version .6
  ** Copyright 1988, Richard S. Sadowsky

  This unit provides an alternative to the standard PRINTER unit.
  The output will be stored in a buffer and printed in the background.

  Requires QBUFMAX heap space as currently coded.

}


Unit BakLPT;

interface

uses DOS,TPInt;

const
  fmClosed         = $D7B0; { magic numbers for Turbo }
  fmInput          = $D7B1;
  fmOutput         = $D7B2;
  fmInOut          = $D7B3;

  IO_Invalid       = $FC;    { invalid operation eg. attempt to write }
                             { to a file opened in fmInput mode       }
  LPT_1            = 0;      { Indicate LPT1 for BIOS int 17h }
  LPT_2            = 1;      { Indicate LPT2 for BIOS int 17h }
  LPT_3            = 2;      { Indicate LPT3 for BIOS int 17h }

  QBUFMAX          = 65521;

  NOT_ENOUGH_HEAP  = -1;
  ALREADY_OPEN     = -2;
  OUT_OF_QUEUE     = -3;
  ISR_NOT_INSTALLED= -4;

type
  DOSMode          = (Cooked,Raw,DefMode);
  QBuffer          = Array[1..QBUFMAX] of Char;
  PrintQueue       = ^QBuffer;
  TextPtr          = ^Text;
  TextBuffer       = array[0..127] of Char;

  QTextRec         = record
                       Handle     : Word;
                       Mode       : Word;
                       BufSize    : Word;
                       Private    : Word;
                       BufPos     : Word;
                       BufEnd     : Word;
                       BufPtr     : ^TextBuffer;
                       OpenFunc   : Pointer;
                       InOutFunc  : Pointer;
                       FlushFunc  : Pointer;
                       CloseFunc  : Pointer;
                       { 16 byte user data area, I use 12 bytes }
                       PrintMode  : Byte;  { not currently used}
                       FormNo     : Byte;  { not currently used}
                       LPTNo      : Word;  { LPT number in [0..2] }
                       QueSize    : Word;
                       EProc      : Pointer;
                       SaveMode   : Boolean;
                       DOS_Mode   : DOSMode;
                       UsrData    : Array[1..4] of byte;
                       Name       : array[0..79] of Char;
                       Buffer     : TextBuffer;
                     end;

var
  BakLptInstalled  : Boolean;
  QueError         : Integer;
  BakError         : Integer;
  PrtQue           : PrintQueue;
  QBI              : Word;
  QOutPtr          : Word;

  Lst              : Text;   { for source compatability with Printer and }
                             { LPT units, and TP3's Lst device }

{ typed constants }
const
  Retry            : Array[0..2] of Word = (20,20,20);
  RetryWait        : Array[0..2] of Word = (25,25,25);
  LPTNames         : array[0..2] of String[4] = ('LPT1','LPT2','LPT3');
  CHARS_PER        : Word = 50; { send out 50 chars per TICKS_TO_WAIT by def.}
  TICKS_TO_WAIT    : Word = 4; { approx 1/4 sec by default }
  SOC_Retries      : Word = 20;
  FilterInt05      : Boolean = TRUE;
  QuePause         : Boolean = FALSE;
  _MODE            : DOSMode = DefMode;
  QueUserExitFunc  : Pointer = NIL;
  QueUserErrorFunc : Pointer = NIL;
  DefaultLstDevice : TextPtr = NIL;

function DoInt17(Ch : Char; LPTNo : Word) : Byte;
{ send a character to LPTNo via ROM BIOS int 17h func 0h }
{ implented as an inline "macro" for speed and the heck  }
{ of it! Bet you've seen this routine before!            }
Inline(
  $5A/         {  pop     DX    ; get printer number}
  $58/         {  pop     AX    ; get char}
  $B4/$00/     {  mov     AH,00 ; set AH for BIOS int 17h function 0}
  $CD/$17/     {  int     $17   ; do an int 17h}
  $86/$E0);    {  xchg    AL,AH ; put byte result in AL}

function LPTStat(LPTNo : Word) : Byte;
Inline(
  $5A/         {  POP    DX      ; get LPT number}
  $B4/$02/     {  MOV    AH,$02  ; int 17h function 2}
  $CD/$17/     {  INT    $17     ; BIOS printer services}
  $86/$C4);    {  XCHG   AH,AL   ; return byte in AH as function result}

function LPTReady(ErrorCode : Word) : Boolean;
Inline(
  $5B/         {  POP  BX}
  $B8/$90/$00/ {  MOV  AX,$90  ; printer select bit}
  $21/$D8/     {  AND  AX,BX   ; check to see if printer sel bit is set}
  $74/$02/     {  JZ   L1      ; printer not ready, false (0) already in AL}
  $B0/$01);    {  MOV  AL,1    ; printer ready so return true (1) in AL}
{L1:}


procedure AssignQue(var F : Text; LPTNumber : Word;
                    QueueSize : Word);
{ like Turbo's assign, except associates Text variable with one of the LPTs }

procedure ResetQueue(BufferToo : Boolean);

implementation

const
  INT1C_HANDLE     = 15;
  INT05_HANDLE     = 16;

  STDPRN           = 4;

  TIMER_STACK_SIZE = 1024;

  InTimerISR       : Boolean = TRUE; { int 1Ch semaphore }

var
  ExitSave         : Pointer;
  SaveMode         : Boolean;
  TimerStack       : Array[1..TIMER_STACK_SIZE] of Byte;

function BoolFuncFarCall(ProcAddr : Pointer) : Boolean;
inline(
  $89/$E3/               {  mov bx,sp}
  $36/$FF/$1F/           {  call far dword ptr ss:[bx]}
  $81/$C4/$04/$00);      {  add sp,4}

function DoUserExit : Boolean;

begin
  if QueUserExitFunc <> NIL then
    DoUserExit := BoolFuncFarCall(QueUserExitFunc)
  else
    DoUserExit := FALSE;
end;

{$F+} { <==The following routines MUST be compiler as FAR }

procedure ExitHandler;
{ Restore the original device mode and close file }

begin

  ExitProc := ExitSave;  { Chain to other exit procedures }

  Close(Lst); { this triggers LstClose and possibly UserExitFunc if }
              { chars are left in the queue buffer }

end;

function LstOpen(var F : QTextRec) : Integer;

begin
  if PrtQue <> NIL then begin { if a queue exists then Lst is already open }
    QueError := ALREADY_OPEN;
    LstOpen := QueError;      { return the error condition and exit }
    Exit
  end;

  with F do begin
    Handle     := StdPRN;     { I'm not sure why I'm doing this!!! }
    Mode := fmOutput;         { make sure it knows this is output only }
    GetMem(PrtQue,F.QueSize); { allocate the print queue on the heap }
    QBI := 0;                 { set the Queue Buffer Index to 0 }
    QOutPtr := 0;             { set queue output pointer to 0   }
    if PrtQue = NIL then      { make sure there was sufficient memory }
        QueError := NOT_ENOUGH_HEAP
      else
        QueError := 0;
    DefaultLstDevice := @F;
  end;

  InterruptsOff;        { flip Interrupts off for some important business }
  FilterInt05 := FALSE; { ignore print screens while background printing }
  InTimerISR := FALSE;  { This starts the TimerISR a'tickin' }
  InterruptsOn;         { Don't forget to turn em on }

  LstOpen := QueError;  { return this for IOResult }
end;

function LstClose(var F : QTextRec) : Integer;

var
  ErrorCode        : Integer;
  Abort            : Boolean;
  DontCare         : boolean;

begin
  ErrorCode := 0;
  with F do begin
    repeat
      if (QBI > 0) and (QueUserExitFunc <> NIL) then
        Abort := DoUserExit
      else
        Abort := TRUE;
    until Abort;

    Mode       := fmClosed;

    FreeMem(PrtQue,F.QueSize);
    PrtQue := NIL;
  end;
  DefaultLstDevice := NIL;
  InterruptsOff;
  InTimerISR := TRUE;
  FilterInt05 := TRUE;
  InterruptsOn;
  LstClose := ErrorCode;
end;

function LstOutput(var F : QTextRec) : Integer;
{ Send whatever has accumulated in the Buffer to int 17h   }
{ If error occurs, return in IOResult.  See Inside Turbo   }
{ Pascal chapter of TP4 manual for more info on TFDD       }
var
  I                : Word;
  ErrorCode        : Integer;

begin
  InterruptsOff;

  I := QBI;
  Inc(QBI,F.BufPos);  { increment QBI by number of chars in QTextRec buffer }
  if (QBI > F.QueSize) or (QBI < I) then { check for overflow }
    QueError := OUT_OF_QUEUE  { return error code }
  else begin
    Inc(I);
    Move(F.BufPtr^[0],PrtQue^[I],F.BufPos); { move from QTextRec buff to que }
    QueError := 0;
  end;
  F.BufPos := 0; { reset BufPos }
  InterruptsOn;
  LstOutput := QueError;
end;

{$F-} { Near ok now }

procedure AssignQue(var F : Text; LPTNumber : Word;
                    QueueSize : Word);
{ like Turbo's assign, except associates Text variable with one of the LPTs }
begin
  with QTextRec(F) do begin
    Mode       := fmClosed;
    BufSize    := SizeOf(Buffer);
    BufPtr     := @Buffer;
    OpenFunc   := @LstOpen;   { open a print queue }
    CloseFunc  := @LstClose;  { close a print queue }
    InOutFunc  := @LstOutput; { you can Write and WriteLn to them }
    FlushFunc  := @LstOutput;
    LPTNo      := LPTNumber;  { user selected printer num (in [0..2]) }
    QueSize    := QueueSize;
    Move(LPTNames[LPTNumber],Name,4); { set name of device }
    BufPos := 0; { reset BufPos }
  end;
end;

procedure ResetQueue(BufferToo : Boolean);

begin
  { reset out pointer to 0 and if BufferToo then the buffer index also }
  QOutPtr := 0;
  if BufferToo then
    QBI := 0;
end;

function SendOutChar(C : Char; LPTNo : Word) : Byte;

var
  ErrorCode        : Word;

begin
  with QTextRec(DefaultLstDevice^) do begin
    ErrorCode := LPTStat(LPTNo);
    if LPTReady(ErrorCode) then begin
      ErrorCode := DoInt17(C,LPTNo);
      if LPTReady(ErrorCode) then
        SendOutChar := 0
      else
        SendOutChar := ErrorCode
    end
    else
      SendOutChar := ErrorCode;
  end; {with}
end;

procedure Int05Handler(BP : Word); Interrupt;
{ if FilterInt05 is FALSE, we will safely ignore all requests to print the }
{ screen }
var
  Regs             : IntRegisters absolute BP;

begin
  if FilterInt05 then
    ChainInt(Regs,ISR_Array[Int05_HANDLE].OrigAddr); { filter it }

end;

procedure QueueSystem(var Regs : IntRegisters);

{ be as gentle as possible on the stack }

var
  I                : Integer;

{ type constants are used to avoid declaring these on the stack }
const
  ResetTheBuffer   : Boolean = FALSE;
  NumToDo          : Word = 0;
  CTP              : Word = 0;

Begin
  CTP := QBI - QOutPtr;
  if CHARS_PER < CTP then begin
    NumToDo        := CHARS_PER;
    ResetTheBuffer := FALSE;
  end
  else begin
    ResetTheBuffer := TRUE;
    NumToDo        := CTP;
  end;
  I := 1;
  while (I <= NumToDo) and (BakError = 0) do begin
    Inc(QOutPtr);

    BakError := SendOutChar(PrtQue^[QOutPtr],
                            QTextRec(DefaultLstDevice^).LPTNo);
    if (BakError <> 0) and (QueUserErrorFunc <> NIL) then begin
      { force reset if user error func returns TRUE. }
      Dec(QOutPtr); { adjust QOutPtr to point to last successfully }
                    { printed character }
      ResetTheBuffer:= BoolFuncFarCall(QueUserErrorFunc);
    end;
    Inc(I);
  end; { while }
  if ResetTheBuffer then ResetQueue(TRUE);
end;

procedure TimerISR(BP : Word); Interrupt;
var
  Regs             : IntRegisters absolute BP;

const
  Ticks            : Word = 0;

begin
  EmulateInt(Regs,ISR_Array[Int1C_HANDLE].OrigAddr); { always filter int 1Ch! }
  InterruptsOff; { I am paranoid about interrupts while checking semaphores }
  if InTimerISR then begin
    InterruptsOn;
    Exit;
  end;
  Inc(Ticks);
  InTimerISR := TRUE; { set global in-use semaphore }
  InterruptsOn;


  if (not QuePause) and (Ticks MOD TICKS_TO_WAIT = 0) then
    SwapStackAndCallNear(Ofs(QueueSystem),
                         @TimerStack[TIMER_STACK_SIZE],Regs);

  InterruptsOff; { more paranoia }
  InTimerISR := FALSE; { clear global in-use semaphore }
  InterruptsOn;

end;

begin
  BakLptInstalled := FALSE;
  PrtQue := NIL;
  QueError := 0;
  BakError := 0;

  AssignQue(Lst,LPT_1,QBUFMAX);
                           { set up turbo pascal compatable Lst device }
                           { that prints in the background using       }
                           { biggest possible buffer (about 64k).      }

  Rewrite(Lst);            { open it for output }

  QueError := IOResult;
  if QueError = 0 then begin
    ExitSave := ExitProc;    { save old exit handler }
    ExitProc := @ExitHandler;{ set new exit handler  }


    if InitVector($1C,Int1C_HANDLE,@TimerISR) and
                 InitVector($05,INT05_HANDLE,@Int05Handler) then begin
      BakLptInstalled := TRUE;
      QueError        := 0;
    end
    else
      QueError        := ISR_NOT_INSTALLED;
  end;
end.