home *** CD-ROM | disk | FTP | other *** search
/ Jason Aller Floppy Collection / 153.img / TELES.ZIP / TYPEW.PAS < prev    next >
Pascal/Delphi Source File  |  1988-04-04  |  6KB  |  224 lines
  1. {$R-}    {Range checking off}
  2. {$B+}    {Boolean complete evaluation on}
  3. {$S+}    {Stack checking on}
  4. {$I+}    {I/O checking on}
  5. {$N-}    {No numeric coprocessor}
  6. {$M 65500,16384,655360}
  7.  
  8. program typew;
  9.  
  10. Uses
  11.   Crt;
  12.  
  13. type
  14.   str =string[255];
  15.  
  16. var
  17.   i,pap   : integer;
  18.   filv:text;
  19.   filn:string[12];
  20.   n   :string[255];
  21.   c   :integer;
  22. okansi,nofeed:boolean;
  23. hangup:boolean;
  24. nopfile:boolean;
  25. nofile:boolean;
  26.  
  27. procedure centre(var i:str);   (* Center I String *)
  28. var n,n1:integer;
  29. begin
  30.   if i[1]=#2 then i:=copy(i,2,length(i)-1);
  31.   n:=length(i); n1:=1;
  32.   while (n1<=length(i)) do begin
  33.     if i[n1]=#3 then begin
  34.       n:=n-2;
  35.       n1:=n1+1;
  36.     end;
  37.     n1:=n1+1;
  38.   end;
  39.   if n<80 then
  40.     i:=copy('                                               ',1,
  41.       (80-n) div 2)+i;
  42. end;
  43.  
  44. procedure checkhangup;
  45. begin
  46. end;
  47.  
  48. procedure print(i:str);
  49. begin
  50.   writeln(i);
  51. end;
  52.  
  53. procedure prompt(i:str);
  54. begin
  55.   write(i);
  56. end;
  57.  
  58. procedure nl;
  59. begin
  60.   writeln;
  61. end;
  62.  
  63. procedure cl(i:integer);
  64. begin
  65.   if i=0 then begin textcolor(15); textbackground(0); end;
  66.   if i=1 then begin textcolor(3); textbackground(0); end;
  67.   if i=2 then begin textcolor(1); textbackground(0); end;
  68.   if i=3 then begin textcolor(11);textbackground(0); end;
  69.   if i=4 then begin textcolor(9); textbackground(0);end;
  70.   if i=5 then begin textcolor(14);textbackground(0);end;
  71.   if i=6 then begin  textcolor(15); textbackground(1); end;
  72.   if i=7 then begin textcolor(4); textbackground(0);end;
  73.   if i=8 then begin textcolor(12+16);textbackground(0);end;
  74.   if i=9 then begin textcolor(10);textbackground(0);end;
  75.  end;
  76.  
  77. procedure printa1(i:str; var abort,next:boolean);  (* Print line of text *)
  78. var c:integer;
  79. begin
  80.  checkhangup;
  81.  if not hangup then begin
  82.   abort:=false; next:=false; c:=1;
  83.   while (not abort) and (c-1<length(i)) and (not hangup) do begin
  84.     checkhangup;
  85.     if (c-1<length(i)) then begin
  86.       if i[c]=chr(8) then begin
  87.         pap:=pap-1;
  88.         delay(30);
  89.       end else
  90.         if i[c]=#3 then begin
  91.            if i[c+1] in [#0..#9] then
  92.             if okansi then
  93.               cl(ord(i[c+1]));
  94.         end else
  95.            if i[c]<>chr(10) then pap:=pap+1;
  96.       if i[c]=#3 then
  97.         c:=c+1
  98.       else
  99.        if (i[c]<>#29) then write(i[c]);
  100.        c:=c+1;
  101.     end;
  102.   end;
  103.  end else abort:=true;
  104. end;
  105.  
  106. procedure printa(i:str; var abort,next:boolean);
  107. var s:str; p,op,rp,rop,nca:integer; crend:boolean;
  108. begin
  109.   nofeed:=false;
  110.   abort:=false;
  111.   nopfile:=false;
  112.   crend:=(i[length(i)]=#1) and (i[length(i)-1]<>#3);
  113.   if i[length(i)]=#29 then nofeed:=true;
  114.   if crend then i:=copy(i,1,length(i)-1);
  115.   if i[1]=#2 then begin
  116.     centre(i);
  117.     printa1(i,abort,next);
  118.     nl;
  119.   end else begin
  120.     if i='' then nl;
  121.     while (i<>'') and (not abort) and (not hangup) do begin
  122.       rp:=0;
  123.       if pos(#27,i)=0 then nca:=80-pap-1 else nca:=255;
  124.       p:=0;
  125.       while (rp<nca) and (p<length(i)) do begin
  126.         if i[p+1]=#8 then rp:=rp-1 else
  127.           if i[p+1]=#3 then
  128.             p:=p+1
  129.           else
  130.             if (i[p+1]<>#10) then rp:=rp+1;
  131.         p:=p+1;
  132.       end;
  133.       op:=p; rop:=rp;
  134.       if (rp>=nca) and (p<length(i)) then begin
  135.         while ((not (i[p] in [' ',#8,#10])) or (i[p-1]=#3)) and (p>1) do begin
  136.           rp:=rp-1; p:=p-1;
  137.         end;
  138.         if p=1 then
  139.           if not (i[1] in [' ',#8,#10]) then begin rp:=rp-1; p:=p-1; end;
  140.       end;
  141.       if abs(rop-rp)>=(80 div 2) then p:=op;
  142.       s:=copy(i,1,p); delete(i,1,p);
  143.       if (s[length(s)]=' ') and not nofeed then s[0]:=pred(s[0]);
  144.       printa1(s,abort,next);
  145.       if ((i='') and crend) or (i<>'') or abort then
  146.         if (nofeed=false) then nl
  147.       else
  148.         IF NOFEED=FALSE THEN printa1(' ',abort,next);
  149.     end;
  150.   end;
  151. end;
  152.  
  153. procedure printacr(i:str; var abort,next:boolean);
  154. begin
  155.  if not abort then
  156.   if (i[length(i)]=#1) or (i[length(i)]=#29) then
  157.     printa(i,abort,next)
  158.   else
  159.     printa(i+#1,abort,next);
  160. end;
  161.  
  162. procedure pfl(fn:str; var abort:boolean; cr:boolean);
  163. var fil:text;
  164.     i:str;
  165.     ofn:str;
  166.     p:integer;
  167.     next:boolean;
  168. begin
  169.   nofile:=false;
  170.     if not hangup then begin
  171.       assign(fil,fn);
  172.       {$I-} reset(fil); {$I+}
  173.       if ioresult<>0 then nofile:=true else
  174.       begin
  175.        abort:=false;
  176.         while not eof(fil) and (not abort) and (not hangup) and (nofile=false) do begin
  177.           readln(fil,i);
  178.           if cr then
  179.             printacr(i,abort,next)
  180.           else
  181.             printa(i,abort,next);
  182.         end;
  183.         close(fil);
  184.       end;
  185.     end;
  186.   nl;
  187. end;
  188.  
  189. procedure printfile(fn:str);         (* Print normal text file *)
  190. var abort:boolean;
  191. begin
  192.   pfl(fn,abort,true);
  193. end;
  194.  
  195. begin
  196.   nofeed:=false;
  197.   nopfile:=false;
  198.   nofile:=false;
  199.   hangup:=false;
  200.   okansi:=true;
  201.   for i := 1 to ParamCount do
  202.     filn:=ParamSTR(i);
  203.   assign(filv,filn);
  204.   {$I-} reset(filv); {$I+}
  205.   if ioresult<>0 then begin
  206.     writeln;
  207.     textcolor(10);
  208.     writeln('TYPE WWIV - A DOS Utility Written By Carl Mueller');
  209.     textcolor(11);
  210.     writeln;
  211.     writeln('Command syntax as follows:');
  212.     writeln('TYPEW [d:][path][filename]');
  213.     writeln;
  214.     textcolor(15);
  215.     writeln('TYPEW was written in Turbo Pascal 4.0 and designed to list');
  216.     writeln('WWIV color coded files in DOS mode.  This program will work');
  217.     writeln('also with software such as TELEGARD or TAG which uses the');
  218.     writeln('same format.');
  219.     writeln;
  220.   end else begin
  221.   printfile(filn);
  222.   end;
  223. end.
  224.