Programmer 7500/MAX_PROGRAMMERS.iso/INFO/TURBOPAS/TPPROC19.ZIP/FILPRN.PAS

Pascal/Delphi Source File | 1985-09-02 | 11.0 KB | 406 lines

{           PRNT2.PAS      10/24/84
Copyright (c) 1985 Scott Daniels
Prints any text file with Date & Time & Page # at top of page

revisions
Ver 1.2  1/20: uses Command Tail now
Ver 1.3  1/24: max line length=132 vice 80; prints long lines Compressed
Ver 1.31 2/28: revised include file names, eg GetFilNm.Inc


*** NOTICE:
This program is hereby placed into the Public Domain,  for non-commercial use
only.  The author,  Scott Daniels of Turtle Micro-Ware Co./East Lyme, CT 06333
retains sole commercial rights to this program}

Program Prnt;

{TEMPORARY LINE TO TEST PRINTING OF >80 CHARACTER LINES IN THIS FILE PRNT2.PAS, THIS IS SO FAR 98 CHARS LONG,LET'S SEE !!!}


{$R-  Range Index check: - passive}
{$U+  User Interrupt: + enabled   }
{$V-  String Var Param Type Checking: - passive}
{$X-  Array Optimization: - disabled}
{$C+  Control S,C: + enabled }

type
  Anystring   = string[70];
  String14    = string[14];
  regpack = record
                ax,bx,cx,dx,bp,si,ds,es,flags: integer;
              end;
var
     recpack : regpack;

var
  Control_Str : string[80];  {printer control string}
  Escape      : boolean;
  Ch          : Char;        { Current character being scanned }
  Line        : Integer;   { display line # for next write}
  KeyNo       : char;
  MenuFn      : AnyString;
  SuFile      : text;   {file of char}
  TestFile,
  FileName    : string14;
  DriveNo     : string[2];

const
  VersionNo   = '1.31I';       {I:Itoh; E:Epson}
  RevDate     = 'Jan. 24, 1985';
  EofLine     = ^M;
  DefaultDrv  = 'B:';
  TestName    = 'Test.Txt';
  Compress_On = '15';      {for Epson FX-80, use '15'; for C-Itoh 8510 use '27:81'}
  Compress_Off= '18';      {Epson: 18; Itoh: 27:78}


(* You may wish to separate the following groups of procedures into separate
files, so they may be used with other programs. If so, use the following
declarations when compiling the program :

{$I Strings.Inc}       {String functions}
{$I DosCall.Inc}       {DOS function Call for Date/Time}
{$I DateTime.Inc}      {Date/Time via DOS function $2A,$2C}
{$I Exist.Inc}         {Disk file exist? fn for GetFilNm}
{$I GetFilNm.Inc}      {user input of filename}
{$I CmdTail.Inc}       {gets command line drive & filename}  *)

{*******************************************************************}
{*                       PROCEDURES                                *}
{*******************************************************************}

{++++++++++++ INCLUDE FILES +++++++++++++++++
NOTE: The following files are required for the above program. They may be left
here as they are, or split out into separate Include files. }

{---------------- STRINGS.INC      10/24/84   Rev 1/24/85 }
{An Include file: a collection of string handling routines}

const
  LineWidth = 80;   {video line width}


{*** UPPER: converts all chars of a string to upper case}
function Upper(InString:Anystring):Anystring;
var
    charpos : integer;
    temp : anystring;

begin
    FillChar(Temp,70,#32);
    for charpos := 1 to length(InString) do Temp[charpos]:=UpCase(InString[charpos]);
    Upper := Temp;
end; {function}



{*** ASC: gives ascii number for the given character *** DELETE ???}
{NOTE: built-in fn Integer(ch) gives same result}
function Asc(Ch:Char):integer;
begin
   Asc := Ord(Ch);
end;


{*** RIGHT yields right-most characters of a string ***}
function Right(Str:AnyString;NChars:integer):AnyString;
begin
  Right := Copy(Str,Length(Str)+1-NChars,NChars);
end; {Right}


{***STRNG converts positive integer to string with no spaces, eg 9='9' ***}
function Strng(Value:integer):AnyString;
var
  temp     : AnyString;
  ndigits  : integer;
begin
   Str(Value:5,Temp);
   if Value <10 then ndigits := 1 else
   if Value <100 then ndigits := 2 else
   if Value <1000 then ndigits := 3 else
   if Value <10000 then ndigits := 4 else
   ndigits := 5;
   Temp := Right(Temp,ndigits);
   Strng := Temp;
end; {Strng}


{*** TSTRNG converts value to string; adds leading zero if <10; eg 9 = "09"}
function TStrng(Value:integer):AnyString;
var
   temp       : AnyString;
begin
   Temp := Strng(Value);           {convert to string}
   if Value < 10 then Temp := '0'+ Temp;
   TStrng := Temp;
end; {TStrng}


{*** DISP: displays 2 strings on selected line ***}
procedure Disp(X,Y:integer;Str1,Str2:AnyString);
begin
     GoToXY(X,Y);
     Write(Str1); Writeln(Str2);
end;


{*** CENTERSTR centers a string on the selected Line ***}
procedure CenterStr(Line:integer;Str:AnyString);
var
   strlen,blanks: integer;
begin
     StrLen := Length(Str);
     Blanks := Round((LineWidth-StrLen)/2);
     GoToXY(Blanks,Line);
     Writeln(Str);
{     GoToXY(1,23);Writeln(strlen,'/',blanks);}     { Diagnostic}
end;


{---------------- *** DOSCALL.INC
calls a DOS fn; Fn is function #, which goes into AH reg}
{NOTE: variable recpack is globally defined in the calling program}

procedure DosCall(Fn:integer);

begin
  with recpack do
  begin
    ax := Fn shl 8;
  end;
  MsDos(recpack);                        { call function }
end;



{---------------- **** DATETIME.INC  Library file    10/28/84; rev 1/19/85}
{NOTE: variable recpack is globally defined in the calling program}

{uses following .INC files}
{DosCall.Inc - performs the DOS function call}
{Strings.Inc - converts number to string, with leading '0' if <10}

type
   DateStr = string[10];
   TimeStr = string[8];

{*** DATE calls DOS fn 2A; on return CX:DX contains date}
{ year = CX (1984...); month = DH (1=Jan); day = DL}
function Date:DateStr;

var
  month,day : string[2];
  year      : string[4];

begin
  DosCall($2A);
  with recpack do
  begin
    str(cx,year);                        {convert CX binary to string}
    day := Tstrng(dx mod 256);                 {convert DX to DL, string}
    month := Tstrng(dx shr 8);                 {convert DX to DH, string}
  end;
  date := month+'/'+day+'/'+year;
end;


{*** TIME uses DOS fn 2C}
function Time:TimeStr;

var
  hr,mins,secs : string[2];

begin
  DosCall($2C);
  with recpack do
  begin
      hr := Tstrng(cx shr 8);                 {CH}
    mins := Tstrng(cx mod 256);             {CL}
    secs := Tstrng(dx shr 8);               {DH}
  end;
Time := hr+':'+mins+':'+secs;
end;



{---------------- *** EXIST.INC checks that a file exists on the disk}
function Exist(FileN: AnyString): boolean;
var F: file;
begin
   {$I-}
   assign(F,FileN);
   reset(F);
   {$I+}
   if IOResult<>0 then
    Exist:=false
   else Exist:=true;
end; {fn exist}


{---------------- *** GETFILNM.INC      10/24/84   Rev /    AN INCLUDE FILE}
{An Include file: gets file name & check if exists}

var
  LastFile: string14;

procedure GetFilNm(var FileN: String14);
begin
 Escape := False;
 Read(kbd,Ch); if Ch = #27 then Escape := True
 else
   if Ch = #13 then FileName := LastFile      {CR}
 else
   begin
      Write(Ch);
      Readln(FileName); FileName := Ch + FileName;
      if length(FileName) > 14 then
         begin Writeln('Filespec too long - max 14 chars-');
         GetFilNm(FileName);
         end  {if length}
      else
      if FileName = '' then FileName := LastFile;
      if not(Exist(FileName)) then
         repeat
            Write('File not found. Re-enter >');
            GetFilNm(FileName);
         until exist(FileName);
      LastFile := FileName;     {last file read}
 end; {if #27}
end; {GetFileName}


{---------------- *** CMDTAIL    1/20/85     an INCLUDE FILE}
{Decodes command tail of drive,commands when a program is invoked}
{eg, if call 'PRNT B:Test.Txt', will run Prnt.Com program and pass}
{ the command tail = 'B:Test.Txt' to the program}
{ref: Borland SIG; also TUG newsletter}

var        {global variables}
    CmdTail : string[14] absolute CSeg:$0080;   {eg 'space + B: + filename.ext'}
    Drive : string[2];

procedure GetTail;

begin
    CmdTail := Copy(CmdTail,2,Length(CmdTail)-1);  {chop off initial space}
    If Pos(':',CmdTail) <>0 then Drive := Copy(CmdTail,1,2) else Drive:='';
end; {Procedure CmdTail}

{-------------------------------------------------------------------------
The remainder of the program's Procedures & Functions follows :}

{*** WELCOME: Initial Screen ***}
Procedure Welcome;
begin
    CenterStr(1,'File Print Program');
    CenterStr(2,'Version: '+VersionNo+'    '+RevDate);
    CenterStr(3,'Copyright (c) 1985 by: S. Daniels');
    CenterStr(4,'Turtle Micro-Ware Co.');
    CenterStr(5,'9 Joval Street - East Lyme, CT 06333');
    CenterStr(6,'Phone: [phone]');
    CenterStr(8,'*** DONATIONS KINDLY ACCEPTED ***');
end;


{*** INIT: Initialize any variables ***}
Procedure Init;
begin
   DriveNo  := DefaultDrv;
end;


{*** PRINTER_CONTROL: sends one char at a time of Control_Str, to printer}
procedure Printer_Control(Control_Str:Anystring);
var
     Posn,TempVal,ErrCode : integer;
     Str1 : Anystring;

begin
     Posn := 1;
     while Posn <Length(Control_Str) do begin
          Str1 := Concat(Control_Str[Posn],Control_Str[Posn+1]);
          Val(Str1,TempVal,ErrCode);
          write(Lst,Chr(TempVal));
          Posn := Posn+3;             {skip the ':'}
     end; {while Posn}
end; {procedure}


{*** COMPRESS_MODE: sets printer to compress or normal for each line}
procedure Compress_Mode(Compress:boolean);
var
   k : integer;
begin
   Case Compress of
      True:  Printer_Control(Compress_On);
      False: Printer_Control(Compress_Off);
   end; {case Mode}
end; {procedure}



procedure PrntHeading(FNam:string14; var PgNo:integer);
begin
   Write(Lst,'Listing of >> ',FNam,' <<   ');
   Writeln(Lst,Date,'      ',Time,'       Page ',PgNo:4);
   Writeln(Lst);
end; {PrntHeading}


procedure GetName;
begin
   Write('Enter file name, or ^C to Quit: ');
   GetFilNm(FileName);
end; {GetName}


procedure PrntFile;     {send to prtr}
var
   PgNo,LineNo: integer;
   FileLine: string[132];

begin
   CenterStr(10,'now PRINTING '+FileName+'...');
   PgNo := 1;
   PrntHeading(FileName,PgNo); LineNo := 3;
   Assign(SuFile,FileName);
   Reset(SuFile);
   repeat
        Readln(SuFile,FileLine);
        If Length(FileLine)>80 then Compress_Mode(True) else Compress_Mode(False);
        Writeln(Lst,FileLine);
        LineNo := LineNo + 1;
        if LineNo >60 then begin
          LineNo:=2; PgNo := PgNo + 1;
          Writeln(Lst,#12);             {form-feed}
          PrntHeading(FileName,PgNo);
        end; {if}
   until eof(SuFile);
   Writeln(Lst); Writeln(Lst,#12);
end; {DispFile}


{*********************************************************************}
{*          MAIN PROGRAM SECTION                                     *}
{*********************************************************************}

begin
  Welcome;
  Init;
  GetTail; if CmdTail='' then GetName else
  begin
    FileName:=CmdTail;
    if not(Exist(FileName)) then GetName;
  end;
  FileName := Upper(FileName);
  PrntFile;
  Writeln;
  Writeln('* DONE *');
end.