home *** CD-ROM | disk | FTP | other *** search
/ Power-Programmierung / CD1.mdf / magazine / insidetp / 1990_04 / conprnio.pas < prev    next >
Pascal/Delphi Source File  |  1990-03-19  |  4KB  |  224 lines

  1. UNIT ConPrnIO;
  2.  
  3. INTERFACE
  4.  
  5.   USES DOS;
  6.   VAR
  7.     ConPrn : Text;
  8.  
  9.   PROCEDURE SetLptNbr(PrinterPort: Byte);
  10.  
  11. IMPLEMENTATION
  12.  
  13.   VAR
  14.     IOBuffer : ARRAY[0..255] OF Char;
  15.     OldExitProc : Pointer;
  16.  
  17. {$F+}
  18.   PROCEDURE ExitConPrn;
  19.   BEGIN
  20.     ExitProc := OldExitProc;
  21.     Close(ConPrn)
  22.   END;
  23.  
  24. {------------------------------}
  25.  
  26.   PROCEDURE SetLptNbr;
  27.  
  28.       FUNCTION NbrLpts: Integer;
  29.       VAR
  30.         Regs : Registers;
  31.       BEGIN
  32.         Intr($11,Regs);
  33.         NbrLpts := Regs.AH SHR 6
  34.       END;
  35.  
  36.  
  37.   BEGIN
  38.     IF NbrLpts = 0 THEN
  39.       BEGIN
  40.         WriteLn('No printer port installed');
  41.         Halt(1)
  42.       END;
  43.  
  44.     WITH TextRec(ConPrn) DO
  45.       BEGIN
  46.     IF PrinterPort <= NbrLpts THEN
  47.       UserData[1] := PrinterPort - 1
  48.     ELSE
  49.       UserData[1] := 0  {Default to LPT1}
  50.       END
  51.   END;
  52.  
  53. {------------------------------}
  54.  
  55.   FUNCTION OutPrn(VAR F: TextRec; ch : Char):
  56.                                          Integer;
  57.     FUNCTION GetPrnStatus(PrnPort: Byte): Boolean;
  58.  
  59.       VAR
  60.         Regs : Registers;
  61.         NbrPasses : Byte;
  62.       CONST
  63.         Retries : Byte = 100;
  64.  
  65.       BEGIN
  66.  
  67.         NbrPasses := 0;
  68.         GetPrnStatus := TRUE;
  69.  
  70.         WITH Regs DO
  71.           BEGIN
  72.             REPEAT
  73.                AH := $02;
  74.                DX := F.UserData[1];
  75.                Intr($17,Regs);
  76.                AH := AH AND $90;
  77.                IF (AH <> $90) AND
  78.                   (NbrPasses < Retries) THEN
  79.                  Inc(NbrPasses)
  80.             UNTIL (NbrPasses > Retries) OR
  81.                   (AH = $90);
  82.             IF AH <> $90 THEN
  83.                GetPrnStatus := FALSE;
  84.           END
  85.       END;
  86.  
  87.  
  88.     VAR
  89.       Regs : Registers;
  90.       ChByte : Byte;
  91.  
  92.     BEGIN
  93.       ChByte := Ord(ch);
  94.       WITH Regs DO
  95.         BEGIN
  96.       IF GetPrnStatus(F.UserData[1]) THEN
  97.         BEGIN
  98.           AH := $00;
  99.               AL := ChByte;
  100.           DX := F.UserData[1];
  101.           Intr($17,Regs);
  102.           OutPrn := 0;
  103.         END
  104.       ELSE
  105.         OutPrn := 160
  106.         END
  107.       END;
  108.  
  109. {------------------------------}
  110.  
  111.   FUNCTION InOutConPrn(VAR F: TextRec): Integer;
  112.  
  113.  
  114.     PROCEDURE OutCon(ch : Char; DspPage : Byte);
  115.     VAR
  116.       Regs : Registers;
  117.     BEGIN
  118.       Regs.AH := $0E;    {Write TTY character}
  119.       Regs.AL := Byte(ch);
  120.       Regs.BH := DspPage;
  121.       Intr($10,Regs)
  122.     END;
  123.  
  124.  
  125.   VAR
  126.     OutputPos, DspPage : Byte;
  127.     Regs           : Registers;
  128.     Status           : Integer;
  129.  
  130.   BEGIN
  131.     WITH F DO
  132.       BEGIN
  133.     Regs.AH := $0F; {Get Current Display Page}
  134.     Intr($10,Regs);
  135.     DspPage := Regs.BH;
  136.     OutputPos := 0;
  137.     Status := 0;
  138.     InOutConPrn := 0;
  139.     WHILE (OutputPos < BufPos) AND
  140.           (Status = 0) DO
  141.       BEGIN
  142.         OutCon(BufPtr^[OutputPos],DspPage);
  143.         Status := OutPrn(F,BufPtr^[OutputPos]);
  144.         Inc(OutputPos);
  145.         IF Status <> 0 THEN
  146.           InOutConPrn := 160;
  147.       END;
  148.     BufPos := 0;
  149.       END
  150.   END;
  151.  
  152. {------------------------------}
  153.  
  154.   FUNCTION FlushConPrn(VAR F: TextRec): Integer;
  155.   BEGIN
  156.     WITH F DO
  157.       BEGIN
  158.         IF BufPos <> 0 THEN
  159.           FlushConPrn := InOutConPrn(F)
  160.         ELSE
  161.           FlushConPrn := 0
  162.       END
  163.   END;
  164.  
  165. {------------------------------}
  166.  
  167.   FUNCTION CloseConPrn(VAR F: TextRec): Integer;
  168.   {print a ff on printer when closing device}
  169.   BEGIN
  170.     IF F.UserData[1] < 3 THEN
  171.        CloseConPrn := OutPrn(F,Chr(12))
  172.   END;
  173.  
  174. {------------------------------}
  175.  
  176.   FUNCTION OpenConPrn(VAR F: TextRec): Integer;
  177.   BEGIN
  178.     WITH F DO
  179.       BEGIN
  180.     IF Mode = fmOutput THEN
  181.       BEGIN
  182.         InOutFunc    := @InOutConPrn;
  183.         FlushFunc    := @FlushConPrn;
  184.         CloseFunc    := @CloseConPrn;
  185.         FillChar(IOBuffer,SizeOf(IOBuffer),#0);
  186.         OpenConPrn    := 0
  187.       END
  188.     ELSE
  189.       OpenConPrn := 104 {file not open
  190.                          for input or Append}
  191.       END
  192.   END;
  193.  
  194. {$F-}
  195.  
  196. {------------------------------}
  197.  
  198.  
  199.   PROCEDURE AssignConPrn(VAR F : Text);
  200.  
  201.   BEGIN
  202.      WITH TextRec(F) DO
  203.        BEGIN
  204.      Mode         := fmClosed;
  205.      BufSize     := SizeOf(IOBuffer);
  206.      BufPtr         := @IOBuffer;
  207.      OpenFunc    := @OpenConPrn;
  208.      Name[0]     := #0
  209.        END
  210.   END;
  211.  
  212. {-------- UNIT INITIALIZATION SECTION ---------}
  213.  
  214.  
  215. BEGIN
  216.   AssignConPrn(ConPrn);
  217.   Rewrite(ConPrn);
  218.  
  219.   OldExitProc := ExitProc;
  220.   ExitProc := @ExitConPrn;
  221.  
  222.   SetLptNbr(1);           {default to LPT1}
  223. END.
  224.