paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-08-29 19:41:18 +02:00
Code Issues Packages Projects Releases Wiki Activity

* common implementation of unit printer - fix for bug #3421

Browse Source
This commit is contained in:
Tomas Hajny 2004-12-05 11:21:46 +00:00
parent 53038faf19
commit d0191eaa3c
7 changed files with 148 additions and 83 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

14
rtl/amiga/printer.pp
View File

@ -17,20 +17,22 @@
unit printer;
interface
var
lst : text;
{$I printerh.inc}
implementation
{$I printer.inc}
begin
assign(lst,'prt:');
rewrite(lst);
InitPrinter ('prt:');
SetPrinterExit;
end.
{
$Log$
Revision 1.3 2002-09-07 16:01:16 peter
Revision 1.4 2004-12-05 11:21:46 hajny
* common implementation of unit printer - fix for bug 3421
Revision 1.3 2002/09/07 16:01:16 peter
* old logs removed and tabs fixed
}

25
rtl/go32v2/printer.pp
View File

@ -15,32 +15,25 @@
**********************************************************************}
unit printer;
interface
var
lst : text;
{$I printerh.inc}
implementation
var
old_exit : pointer;
procedure printer_exit;
begin
close(lst);
exitproc:=old_exit;
end;
{$I printer.inc}
begin
assign(lst,'PRN');
rewrite(lst);
old_exit:=exitproc;
exitproc:=@printer_exit;
InitPrinter ('PRN');
SetPrinterExit;
end.
{
$Log$
Revision 1.3 2002-09-07 16:01:18 peter
Revision 1.4 2004-12-05 11:21:46 hajny
* common implementation of unit printer - fix for bug 3421
Revision 1.3 2002/09/07 16:01:18 peter
* old logs removed and tabs fixed
}

64
rtl/inc/printer.inc Normal file
View File

@ -0,0 +1,64 @@
{
$Id$
This file is part of the Free Pascal run time library.
Copyright (c) 1999-2004 by the Free Pascal development team
Common part of implementation for unit Printer.
See the file COPYING.FPC, included in this distribution,
for details about the copyright.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
**********************************************************************}
{$I-}
var
Old_Exit: pointer;
LstAvailable: boolean;
function IsLstAvailable: boolean;
begin
IsLstAvailable := LstAvailable;
end;
procedure Printer_Exit;
begin
if LstAvailable then
Close (Lst);
ExitProc := Old_Exit;
end;
procedure InitPrinter (const PrinterName: string);
var
OldInOutRes: word;
begin
(* Avoid potential problems with previous InOutRes value... *)
OldInOutRes := InOutRes;
InOutRes := 0;
Assign (Lst, PrinterName);
Rewrite (Lst);
LstAvailable := InOutRes = 0;
InOutRes := OldInOutRes;
end;
procedure SetPrinterExit;
begin
Old_Exit := ExitProc;
ExitProc := @Printer_Exit;
end;
(* The default $I state is left for potential
platform-specific part of implementation. *)
{$I+}
{
$Log$
Revision 1.1 2004-12-05 11:21:46 hajny
* common implementation of unit printer - fix for bug 3421
}

31
rtl/inc/printerh.inc Normal file
View File

@ -0,0 +1,31 @@
{
$Id$
This file is part of the Free Pascal run time library.
Copyright (c) 1999-2004 by the Free Pascal development team
Common header for unit Printer.
See the file COPYING.FPC, included in this distribution,
for details about the copyright.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
**********************************************************************}
var
Lst: text;
(* Check whether opening of Lst was successful. *)
function IsLstAvailable: boolean;
(* Allow to initialize printer with different name. *)
procedure InitPrinter (const PrinterName: string);
{
$Log$
Revision 1.1 2004-12-05 11:21:46 hajny
* common implementation of unit printer - fix for bug 3421
}

24
rtl/os2/printer.pas
View File

@ -17,30 +17,22 @@
unit printer;
interface
var
lst : text;
{$I printerh.inc}
implementation
var
old_exit : pointer;
procedure printer_exit;
begin
close(lst);
exitproc:=old_exit;
end;
{$I printer.inc}
begin
assign(lst,'PRN');
rewrite(lst);
old_exit:=exitproc;
exitproc:=@printer_exit;
InitPrinter ('PRN');
SetPrinterExit;
end.
{
$Log$
Revision 1.2 2002-09-07 16:01:25 peter
Revision 1.3 2004-12-05 11:21:46 hajny
* common implementation of unit printer - fix for bug 3421
Revision 1.2 2002/09/07 16:01:25 peter
* old logs removed and tabs fixed
}

49
rtl/unix/printer.pp
View File

@ -36,11 +36,7 @@ Interface
{.$DEFINE PRINTERDEBUG}
Const
DefFile = '/tmp/PID.lst';
Var
Lst : Text;
{$I printerh.inc}
Procedure AssignLst ( Var F : text; ToFile : string);
{
@ -63,6 +59,8 @@ Procedure AssignLst ( Var F : text; ToFile : string);
Implementation
Uses Unix,BaseUnix,Strings;
{$I printer.inc}
{
include definition of textrec
}
@ -76,8 +74,6 @@ Const
Var
Lpr : String[255]; { Contains path to lpr binary, including null char }
SaveExit : pointer;
Procedure PrintAndDelete (f:string);
var
@ -180,20 +176,23 @@ end;
Procedure SubstPidInName ( Var s : string);
function SubstPidInName (const S: string): string;
var
i : longint;
temp : string[8];
begin
i:=pos('PID',s);
if i=0 then
exit;
delete (s,i,3);
str(fpGetPid,temp);
insert(temp,s,i);
SubstPidInName := S
else
begin
Str (fpGetPid, Temp);
SubstPidInName := Copy (S, 1, Pred (I)) + Temp +
Copy (S, I + 3, Length (S) - I - 2);
{$IFDEF PRINTERDEBUG}
writeln ('Print : Filename became : ',s);
writeln ('Print : Filename became : ', Result);
{$ENDIF}
end;
end;
@ -207,7 +206,7 @@ begin
exit;
textrec(f).bufptr:=@textrec(f).buffer;
textrec(f).bufsize:=128;
SubstPidInName (Tofile);
ToFile := SubstPidInName (ToFile);
if ToFile[1]='|' then
begin
Assign(f,Copy(ToFile,2,255));
@ -234,27 +233,19 @@ begin
end;
Procedure PrinterExitProc;
begin
close(lst);
ExitProc:=SaveExit
end;
begin
SaveExit:=ExitProc;
ExitProc:=@PrinterExitProc;
AssignLst(Lst,DefFile);
rewrite(Lst);
lpr:='/usr/bin/lpr';
InitPrinter (SubstPidInName ('/tmp/PID.lst'));
SetPrinterExit;
Lpr := '/usr/bin/lpr';
end.
{
$Log$
Revision 1.6 2003-09-20 12:38:29 marco
Revision 1.7 2004-12-05 11:21:46 hajny
* common implementation of unit printer - fix for bug 3421
Revision 1.6 2003/09/20 12:38:29 marco
* FCL now compiles for FreeBSD with new 1.1. Now Linux.
Revision 1.5 2003/09/14 20:15:01 marco

24
rtl/win32/printer.pp
View File

@ -17,30 +17,22 @@
unit printer;
interface
var
lst : text;
{$I printerh.inc}
implementation
var
old_exit : pointer;
procedure printer_exit;
begin
close(lst);
exitproc:=old_exit;
end;
{$I printer.inc}
begin
assign(lst,'PRN');
rewrite(lst);
old_exit:=exitproc;
exitproc:=@printer_exit;
InitPrinter ('PRN');
SetPrinterExit;
end.
{
$Log$
Revision 1.3 2002-09-07 16:01:29 peter
Revision 1.4 2004-12-05 11:21:46 hajny
* common implementation of unit printer - fix for bug 3421
Revision 1.3 2002/09/07 16:01:29 peter
* old logs removed and tabs fixed
}