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

rtl/amiga/printer.pp

@@ -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
 
 }

rtl/go32v2/printer.pp

@@ -15,32 +15,25 @@
 
  **********************************************************************}
 unit printer;
+
 interface
 
-var
-  lst : text;
+{$I printerh.inc}
 
 implementation
 
-var
-  old_exit : pointer;
+{$I printer.inc}
 
-procedure printer_exit;
 begin
-  close(lst);
-  exitproc:=old_exit;
-end;
-
-
-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
 
 }

rtl/inc/printer.inc

@@ -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
+
+
+}

rtl/inc/printerh.inc

@@ -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
+
+
+}

rtl/os2/printer.pas

@@ -17,30 +17,22 @@
 unit printer;
 interface
 
-var
-  lst : text;
+{$I printerh.inc}
 
 implementation
 
-var
-  old_exit : pointer;
+{$I printer.inc}
 
-procedure printer_exit;
 begin
-  close(lst);
-  exitproc:=old_exit;
-end;
-
-
-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
 
 }

rtl/unix/printer.pp

@@ -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

rtl/win32/printer.pp

@@ -17,30 +17,22 @@
 unit printer;
 interface
 
-var
-  lst : text;
+{$I printerh.inc}
 
 implementation
 
-var
-  old_exit : pointer;
+{$I printer.inc}
 
-procedure printer_exit;
 begin
-  close(lst);
-  exitproc:=old_exit;
-end;
-
-
-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
 
 }