CP/M/CPM_CDROM.iso/mbug/mbug117.arc/FOLD.PZS/FOLD.PAS

Pascal/Delphi Source File | 1979-12-31 | 10KB | 382 lines

PROGRAM FOLDFILE;

{-----------------------------------------------------------------------------}
{Programme to page a file like this:                                          }
{                                                                             }
{ line 1 \     / line 1            line pageLength+1    line 2*pageLength+1   }
{ line 2 |     | line 2             ...                  ...                  }
{ line 3 |     | line 3             ...                  ...                  }
{ line 4 |     |  ...                                                         }
{  ...   | --> |  ...                                                         }
{        |     |                                                              }
{        |     |                                                              }
{  ...   |     |  ...               ...                                       }
{ line n /     \ line pageLength   line 2*pageLength                          }
{                                                                             }
{-----------------------------------------------------------------------------}

{$C+}
{$R+}

CONST
   defPageWidth = 79;   {default values}
   defPageLength = 22;
   defNumCols = 3;
   defFenceChar = '-';
   maxPageLength = 100; {as big as the memory limitations allow}
TYPE
   CPMname = string[14];
   fcbname = string[11];
   anyStr = string[255];
   pageArray = array [1..maxPageLength] of anyStr;
VAR
   pageWidth,pageLength : integer;
   inFile,outFile : text;
   inFname,outFname : CPMname;
   lineNumber: integer;
   lineNumbers : boolean;
   currPage : pageArray;
   fenced : boolean;
   fenceChar : char; {appears between pages}
   numCols : integer;

PROCEDURE showSummary;
begin
writeln ('*****************************************************************************');
writeln;
writeln ('command: FOLD - A programme that folds files into pages of columns.');
writeln;
writeln ('syntax:  FOLD infile.ext outfile.ext  {F{c}} {N} {Cn} {Ln} {Wn}} ');
writeln ('                                       |      |   |    |    |');
writeln ('         page break fence char --------+      |   |    |    |');
writeln ('           turn on line numbering ------------+   |    |    |');
writeln ('             n columns per page [3] --------------+    |    |');
writeln ('               n lines per page [22] ------------------+    |');
writeln ('                 n chars per line (excess truncated) [80] --+');
writeln;
writeln ('example: FOLD PROG.PAS PROGLIST.PAS L60 C2 W132 F= N');
writeln;
writeln ('Sam Lander 1988');
writeln;
writeln ('*****************************************************************************');
end;

FUNCTION checkFile(filename : CPMname) : boolean;
var
   checkfl :file;
begin
assign(checkfl,filename);
   {$I-}
   reset(checkfl);
   close(checkfl);
   {$I+}
checkFile:= (IOresult = 0);
end;

FUNCTION defaultDrive: char;
begin
DefaultDrive:= chr(Mem[4] + 65);
end;

PROCEDURE warning(s:anystr);
begin
clreol;
writeln('WARNING: ',s);
end;

PROCEDURE error(s:anystr);
{Writes the string and halts}
begin
writeln;
clreol;
writeln(^g,'ERROR: ',s,'.');
writeln;
showSummary;
halt;
end;

PROCEDURE waitForAck(s:anystr);
{Wait for the user to press a key}
begin
write (^g,'MESSAGE: ',s,' <RET>');
repeat until keypressed;
writeln;
end;

FUNCTION flagSet(c:char): boolean;
var
   i : integer;
   found : boolean;
   testStr : string[2];
begin
found := false;
i := 2; {skip the first two arguments, which are strings}
while (not found) and (i <= paramCount) do
   begin
   i := i+1;
   testStr := paramStr(i);
   if (testStr[1] = upcase(c)) then
      found := true;
   end;
flagSet := found;
end;

FUNCTION flagValue(c:char): integer;
{Returns -1 if the flag '-c' is not found, the value following it otherwise}
var
   i : integer;
   found : boolean;
   testStr : string[7];
   argument,code : integer;
begin
found := false;
flagValue := -1;
i := 3; {skip the first two arguments, which are strings}
argument := 0;
while (not found) and (i <= paramCount) do
   begin
   testStr := paramStr(i);
   if (testStr[1]= upcase(c)) then
      begin
      delete (testStr,1,1);
      val(testStr,argument,code);
      if code = 0 then
         begin
         flagValue := argument;
         found := true;
         end
      else
         error('Numeric argument to '+upcase(c)+' out of range')
      end;
   i := i+1;
   end;
end;

FUNCTION flagString (flagch:char): anystr;
var
   temp: anystr;
   p : byte;
   found : boolean;
begin
found := false;
flagString := '';
p := 3; {skip the first two arguments, which are strings}
while (p<= paramCount) and not(found) do
   begin
   temp := paramStr(p);
   if (temp[1] = upCase(flagch)) then
         begin
         delete(temp,1,1);
         flagString := temp;
         found := true;
         end;
   p := p+1;
   end;
end;

PROCEDURE showSettings;
begin
writeln ('Folding file ',inFname,' to file ',outFname,' using the following settings:');
writeln;
writeln ('   ',numcols,' columns across the page.');
writeln ('   Page width: ',pageWidth,' characters.');
writeln ('   Page length: ',pageLength,' lines.');
write('   Line numbering ');
if linenumbers then
   writeln('on.') else writeln('off.');
if fenced then
   writeln ('   Fence character "',fenceChar,'".')
else
   writeln ('   No fence between pages.');
writeln;
end;

PROCEDURE handleCommandFlags;
{Looks at the command line and changes global variables}
var
   fenceString: string[1];
begin
pageWidth := flagValue('w');
if pageWidth = -1 then
   pagewidth := defPageWidth;
pageLength := flagValue ('l');
if pageLength = -1 then
   pageLength := defPageLength;
numCols := flagValue ('c');
if numCols = -1 then
   numCols := defNumCols;
if flagset('f') then
   begin
   fenced := true;
   fenceString := flagString ('f');
   if fenceString = '' then
      fenceChar := defFenceChar
   else
      fenceChar := fenceString[1];
   end
else
   fenced := false;
if flagSet ('n') then
   linenumbers := true
else
   linenumbers := false;
showSettings;
end;

PROCEDURE init;
begin
lineNumber := 1;
end;

PROCEDURE padOut (var s: anyStr; c: char; n: byte);
{fills the string s out to n characters with c}
var
   i,oldlen : byte;
begin
oldlen := length(s);
s[0] := chr(n);
for i := oldlen+1 to n do
   s[i] := c;
end;

FUNCTION stringArg (snum: byte): anyStr;
{returns the ith string in the command line, -x are ignored}
var
   s : anyStr;
   c,sCount : byte;
begin
stringArg:= '';
sCount := 1;
for c := 1 to paramCount do
   begin
   s := paramstr(c);
   if s[1] <> '-' then
      begin
      if sCount = snum then
         stringArg := s;
      sCount := sCount+1;
      end;
   end;
end;

PROCEDURE getLine(len: integer; var s: anyStr);
var
   errStr:string[40];
begin
s:='';
if not eof(infile) then
   readln (inFile,s)
else
   padout (s,' ',len);
if length(s) > len then
   begin
   errStr := s; {some is truncated off}
   if length (errStr) = 40 then
      warning('Truncated "'+errStr+'..."')
   else
      warning('Truncated "'+errStr+'"');
   s[0] := chr(len);
   end
else
   padout (s,' ',len);
end;

PROCEDURE openFiles;
var
   present : boolean;
begin
inFname := stringArg(1);
if inFname = '' then
   error ('no input file supplied');
present := checkFile (inFname);
if not present then
   error('cannot find file '+inFname);
assign (inFile,inFname);
reset (inFile);
outFname := stringArg(2);
if outFname = '' then
   error ('no output file supplied');
present := checkFile (outFname);
if present then
   waitForAck ('overwriting file '+outFname+'.');
assign (outFile,outFname);
rewrite (outFile);
end;

PROCEDURE closeFiles;
begin
close (inFile);
close(outFile);
end;

PROCEDURE writePage(var p:pageArray); {var parameter to save time and space}
var
   pageLine : integer;
begin
pageLine := 1;
for pageLine := 1 to pageLength do
   writeln (outFile,p[pageLine]);
end;

PROCEDURE blankPage (var p: pagearray);
var i: integer;
begin
for i := 1 to maxPageLength do
   p[i] := '';
end;

PROCEDURE getPage(var p: pageArray);
var
   temp : anyStr;
   extras: byte;
   prefix : string[5];
   pageLine,colWidth,colNum : integer;
   i,start : integer;
begin
blankpage(p);
{first, fix up a page boundary}
if fenced then
   begin
   p[1][0] := chr(pageWidth);
   for i := 1 to pageWidth do
      p[1][i] := fenceChar;
   start := 2;
   end
else
   start := 1;
if lineNumbers then
   extras := numCols*6 + numcols  {digits and a space for a separator}
else
   extras := numcols; {for a separator}
colwidth := trunc((pageWidth-extras) / numCols) - 1;
for colNum := 1 to numCols do
   for pageLine := start to pageLength do
      begin
      getline (colwidth,temp);
      if lineNumbers then
         begin
         str(lineNumber:5,prefix);
         temp := prefix+' '+temp;
         end;
      temp := temp + ' ';
      p[pageline] := p[pageline] + temp;
      lineNumber := lineNumber+1;
      end;
end;
{---   Main bit   ------------------------------------------------------------}
begin
init;
openFiles;
handleCommandFlags;
while not eof(infile) do
   begin
   getpage(currPage);
   writePage(currPage);
   end;
closeFiles;
end.