home *** CD-ROM | disk | FTP | other *** search
/ QBasic & Borland Pascal & C / Delphi5.iso / Pascal / BPASCAL.700 / D12 / UTILDEMO.ZIP / PRNFLTR.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  1992-10-01  |  9.4 KB  |  409 lines
  1. program PrinterOutputFilter;
  2.  
  3. {$M 2048, 0, 0}
  4. {$I-,S-,X+}
  5.  
  6. const
  7.   MaxAttributes = 8;
  8.  
  9. type
  10.   TPCharArray = array[0..16380] of PChar;
  11.   PPCharArray = ^TPCharArray;
  12.  
  13.   PPrinterCodes = ^TPrinterCodes;
  14.   TPrinterCodes = record
  15.     PreambleCount: Byte;
  16.     Preamble: PPCharArray;
  17.     CodeArray: PPCharArray;
  18.     Attributes: array[0..MaxAttributes - 1] of Byte;
  19.     StartPage: PChar;
  20.     EndPage: PChar;
  21.     EndLine: PChar;
  22.     Postamble:  PChar;
  23.   end;
  24.  
  25. const
  26.   EpsonItalic   = #27'4';
  27.   EpsonNoItalic = #27'5';
  28.   EpsonBold     = #27'E';
  29.   EpsonNoBold   = #27'F';
  30.   EpsonULine    = #27'-'#1;
  31.   EpsonNoULine  = #27'-'#0;
  32.  
  33.   EpsonCodeArray: array[0..7] of PChar = (
  34.     EpsonBold,
  35.     EpsonNoBold,
  36.     EpsonItalic,
  37.     EpsonNoItalic,
  38.     EpsonULine,
  39.     EpsonNoULine,
  40.     EpsonBold + EpsonItalic,
  41.     EpsonNoBold + EpsonNoItalic);
  42.  
  43.   EpsonCodes: TPrinterCodes = (
  44.     PreambleCount: 0;
  45.     Preamble: nil;
  46.     CodeArray: @EpsonCodeArray;
  47.     Attributes: (
  48.       0,        { Whitespace }
  49.       2,        { Comment }
  50.       1,        { Reserved word }
  51.       0,        { Identifier }
  52.       0,        { Symbol }
  53.       4,        { String }
  54.       0,        { Number }
  55.       1);       { Assembler }
  56.     StartPage: '';
  57.     EndPage: #12;
  58.     EndLine: #13#10;
  59.     Postamble: ''
  60.   );
  61.  
  62.   HPInit      = #27'E'#27'(10U'#27'&k0S'#27'(s3T';
  63.   HPItalic    = #27'(s1S';
  64.   HPNoItalic  = #27'(s0S';
  65.   HPBold      = #27'(s3B';
  66.   HPNoBold    = #27'(s0B';
  67.   HPULine     = #27'&dD';
  68.   HPNoULine   = #27'&d@';
  69.  
  70.   HPCodeArray: array[0..7] of PChar = (
  71.     HPBold,
  72.     HPNoBold,
  73.     HPItalic,
  74.     HPNoItalic,
  75.     HPULine,
  76.     HPNoULine,
  77.     HPBold + HPItalic,
  78.     HPNoBold + HPNoItalic);
  79.  
  80.   LaserJetPreamble: PChar = HPInit;
  81.   LaserJetCodes: TPrinterCodes = (
  82.     PreambleCount: 1;
  83.     Preamble: @LaserJetPreamble;
  84.     CodeArray: @HPCodeArray;
  85.     Attributes: (
  86.       0,        { Whitespace }
  87.       2,        { Comment }
  88.       1,        { Reserved word }
  89.       0,        { Identifier }
  90.       0,        { Symbol }
  91.       4,        { String }
  92.       0,        { Number }
  93.       1);       { Assembler }
  94.     StartPage: '';
  95.     EndPage: #12;
  96.     EndLine: #13#10;
  97.     Postamble: #12
  98.   );
  99.  
  100.   AsciiCodes: TPrinterCodes = (
  101.     PreambleCount: 0;
  102.     Preamble: nil;
  103.     CodeArray: nil;
  104.     Attributes: (
  105.       0,        { Whitespace }
  106.       0,        { Comment }
  107.       0,        { Reserved word }
  108.       0,        { Identifier }
  109.       0,        { Symbol }
  110.       0,        { String }
  111.       0,        { Number }
  112.       0);       { Assembler }
  113.     StartPage: '';
  114.     EndPage: #12;
  115.     EndLine: #13#10;
  116.     Postamble: ''
  117.   );
  118.  
  119.   PSPreamble0  = #4'%!PS-Adobe-3.0'#13#10+
  120.                 'initgraphics'#13#10;
  121.   PSPreamble1  = '/fnr /Courier findfont 10 scalefont def'#13#10;
  122.   PSPreamble2  = '/fni /Courier-Oblique findfont 10 scalefont def'#13#10;
  123.   PSPreamble3  = '/fnb /Courier-Bold findfont 10 scalefont def'#13#10;
  124.   PSPreamble4  = '/fnbi /Courier-BoldOblique findfont 10 scalefont def'#13#10;
  125.   PSPreamble5  = '/newl {20 currentpoint exch pop 12 sub moveto} def'#13#10+
  126.                  '/newp {20 765 moveto} def'#13#10+
  127.                  'fnr setfont'#13#10;
  128.   PSNormal     = 'fnr setfont'#13#10;
  129.   PSItalic     = 'fni setfont'#13#10;
  130.   PSBold       = 'fnb setfont'#13#10;
  131.   PSBoldItalic = 'fnbi setfont'#13#10;
  132.  
  133.   PSCodeArray: array[0..5] of PChar = (
  134.     PSBold,
  135.     PSNormal,
  136.     PSItalic,
  137.     PSNormal,
  138.     PSBoldItalic,
  139.     PSNormal);
  140.  
  141.   PSPreamble: array[0..5] of PChar = (
  142.     PSPreamble0,
  143.     PSPreamble1,
  144.     PSPreamble2,
  145.     PSPreamble3,
  146.     PSPreamble4,
  147.     PSPreamble5);
  148.   PSCodes: TPrinterCodes = (
  149.     PreambleCount: High(PSPreamble) - Low(PSPreamble) + 1;
  150.     Preamble: @PSPreamble;
  151.     CodeArray: @PSCodeArray;
  152.     Attributes: (
  153.       0,        { Whitespace }
  154.       2,        { Comment }
  155.       1,        { Reserved word }
  156.       0,        { Identifier }
  157.       0,        { Symbol }
  158.       3,        { String }
  159.       0,        { Number }
  160.       1);       { Assembler }
  161.     StartPage: 'newp'#13#10;
  162.     EndPage: 'showpage'#13#10;
  163.     EndLine: 'newl'#13#10;
  164.     Postamble: #4
  165.   );
  166.  
  167.   pmNormal     = $0001;
  168.   pmPostScript = $0002;
  169.  
  170.   PrintMode: Word = pmNormal;
  171.   LinesPerPage: Word = 59;
  172.   ToFile: Boolean = False;
  173.   TabSize: Word = 8;
  174.  
  175. var
  176.   C, LineCount, TabCount: Integer;
  177.   Line, OutputLine: String;
  178.   InputBuffer: array[0..4095] of Char;
  179.   PrinterCodes: PPrinterCodes;
  180.   CurCode, NewCode: Byte;
  181.   AKey: Word;
  182.   Lst: Text;
  183.  
  184. procedure UpStr(var S: String);
  185. var
  186.   I: Integer;
  187. begin
  188.   for I := 1 to Length(S) do S[I] := UpCase(S[I]);
  189. end;
  190.  
  191. procedure SetDeviceRaw(var T: Text); assembler;
  192. asm
  193.     LES    DI,T
  194.     MOV    BX,WORD PTR ES:[DI]
  195.     MOV    AX,4400H
  196.     INT    21H
  197.     TEST    DX,0080H
  198.     JZ    @@1
  199.     OR    DL,20H
  200.     MOV    DH,DH
  201.     MOV    AX,4401H
  202.     INT    21H
  203. @@1:        
  204. end;
  205.  
  206. procedure ProcessCommandLine;
  207. var
  208.   Param: String;
  209.   I: Integer;
  210.  
  211.   function ParamVal(var P: String; Default: Word): Word;
  212.   var
  213.     N, E: Integer;
  214.   begin
  215.     Delete(P, 1, 1);
  216.     Val(P, N, E);
  217.     if E = 0 then
  218.       ParamVal := N
  219.     else
  220.       ParamVal := Default;
  221.   end;
  222.  
  223. begin
  224.   PrinterCodes := @AsciiCodes;
  225.   for I := 1 to ParamCount do
  226.   begin
  227.     Param := ParamStr(I);
  228.     if (Length(Param) >= 2) and ((Param[1] = '/') or (Param[1] = '-')) then
  229.     begin
  230.       Delete(Param, 1, 1);
  231.       UpStr(Param);
  232.       if Param = 'EPSON' then
  233.         PrinterCodes := @EpsonCodes
  234.       else if Param = 'HP' then
  235.         PrinterCodes := @LaserJetCodes
  236.       else if Param = 'ASCII' then
  237.         PrinterCodes := @AsciiCodes
  238.       else if Param = 'PS' then
  239.       begin
  240.         PrinterCodes := @PSCodes;
  241.         PrintMode := pmPostScript;
  242.       end
  243.       else if Param[1] = 'L' then
  244.         LinesPerPage := ParamVal(Param, LinesPerPage)
  245.       else if Param[1] = 'T' then
  246.         TabSize := ParamVal(Param, TabSize)
  247.       else if Param[1] = 'O' then
  248.       begin
  249.         Delete(Param, 1, 1);
  250.         Assign(Lst, Param);
  251.         Rewrite(Lst);
  252.         ToFile := True;
  253.         SetDeviceRaw(Lst);
  254.       end;
  255.     end;
  256.   end;
  257.   if not ToFile then
  258.   begin
  259.     Assign(Lst, 'LPT1');
  260.     Rewrite(Lst);
  261.     SetDeviceRaw(Lst);
  262.   end;
  263. end;
  264.  
  265. procedure PurgeOutputBuf;
  266. begin
  267.   if OutputLine = '' then Exit;
  268.   case PrintMode of
  269.     pmNormal: Write(Lst, OutputLine);
  270.     pmPostScript:
  271.     begin
  272.       Write(Lst, '(');
  273.       Write(Lst, OutputLine);
  274.       Write(Lst, ') show'#13#10);
  275.     end;
  276.   end;
  277.   OutputLine := '';
  278.   if IOResult <> 0 then Halt(1);
  279. end;
  280.  
  281. procedure AddToOutputBuf(AChar: Char);
  282. var
  283.   I: Integer;
  284. begin
  285.   case AChar of
  286.     '(',')','\':
  287.     begin
  288.       case PrintMode of
  289.         pmPostScript:
  290.         begin
  291.           if Length(OutputLine) > 253 then
  292.             PurgeOutputBuf;
  293.           Inc(OutputLine[0]);
  294.           OutputLine[Length(OutputLine)] := '\';
  295.         end;
  296.       end;
  297.     end;
  298.     #9:
  299.     begin
  300.       if Length(OutputLine) > (255 - TabSize) then
  301.         PurgeOutputBuf;
  302.       for I := 1 to TabSize - (TabCount mod TabSize) do
  303.       begin
  304.         Inc(OutputLine[0]);
  305.         OutputLine[Length(OutputLine)] := ' ';
  306.       end;
  307.       Inc(TabCount, TabSize - (TabCount mod TabSize));
  308.       Exit;
  309.     end;
  310.   end;
  311.   if Length(OutputLine) > 254 then
  312.     PurgeOutputBuf;
  313.   Inc(OutputLine[0]);
  314.   OutputLine[Length(OutputLine)] := AChar;
  315.   Inc(TabCount);
  316. end;
  317.  
  318. procedure NewPage(const PCodes: TPrinterCodes);
  319. begin
  320.   PurgeOutputBuf;
  321.   Write(Lst, PCodes.EndPage);
  322.   Write(Lst, PCodes.StartPage);
  323.   LineCount := 0;
  324.   TabCount := 0;
  325. end;
  326.  
  327. procedure NewLine(const PCodes: TPrinterCodes);
  328. begin
  329.   PurgeOutputBuf;
  330.   Write(Lst, PCodes.EndLine);
  331.   Inc(LineCount);
  332.   TabCount := 0;
  333.   if LineCount > LinesPerPage then
  334.     NewPage(PCodes);
  335. end;
  336.  
  337. function GetKey(var Key: Word): Boolean; assembler;
  338. asm
  339.     MOV    AH,1
  340.     INT    16H
  341.     MOV    AL,0
  342.     JE    @@1
  343.     XOR    AH,AH
  344.     INT    16H
  345.     LES    DI,Key
  346.     MOV    WORD PTR ES:[DI],AX
  347.     MOV    AL,1
  348. @@1:
  349. end;
  350.  
  351. begin
  352.   SetTextBuf(Input, InputBuffer);
  353.   ProcessCommandLine;
  354.   LineCount := 0;
  355.   with PrinterCodes^ do
  356.   begin
  357.     if PreambleCount > 0 then
  358.       for C := 0 to PreambleCount - 1 do
  359.         Write(Lst, Preamble^[C]);
  360.     if IOResult <> 0 then Halt(1);
  361.     LineCount := 0;
  362.     CurCode := $FF;
  363.     TabCount := 0;
  364.     Write(Lst, StartPage);
  365.     Line := '';
  366.     while True do
  367.     begin
  368.       if (Line = '') and Eof then
  369.       begin
  370.         PurgeOutputBuf;
  371.         Break;
  372.       end;
  373.       ReadLn(Line);
  374.       if GetKey(AKey) and (AKey = $011B) then
  375.         Halt(1);
  376.       C := 1;
  377.       while C <= length(Line) do
  378.       begin
  379.         case Line[C] of
  380.           #27:
  381.             if (Line[C + 1] >= '1') and (Line[C + 1] <= '8') then
  382.             begin
  383.               NewCode := Attributes[Byte(Line[C + 1]) - $31];
  384.               if NewCode <> CurCode then
  385.               begin
  386.                 PurgeOutputBuf;
  387.                 if (CurCode > 0) and (CurCode < MaxAttributes) then
  388.                   Write(Lst, CodeArray^[(CurCode - 1) * 2 + 1]);
  389.                 if (NewCode > 0) and (NewCOde < MaxAttributes) then
  390.                   Write(Lst, CodeArray^[(NewCode - 1) * 2]);
  391.                 CurCode := NewCode;
  392.               end;
  393.               Inc(C);
  394.             end;
  395.           #12: NewPage(PrinterCodes^);
  396.         else
  397.           AddToOutputBuf(Line[C]);
  398.         end;
  399.         Inc(C);
  400.       end;
  401.       NewLine(PrinterCodes^);
  402.     end;
  403.     if LineCount > 0 then
  404.       Write(Lst, EndPage);
  405.     Write(Lst, Postamble);
  406.   end;
  407.   Close(Lst);
  408. end.
  409.