home *** CD-ROM | disk | FTP | other *** search
/ Programmer 7500 / MAX_PROGRAMMERS.iso / PASCAL / CUTPAS12.ZIP / CUT.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  1991-01-05  |  3.4 KB  |  150 lines
  1. program Cut_File;
  2.  
  3. USES Rline;
  4.  
  5. TYPE
  6.   RFtester = Object(RFextended)
  7.     PROCEDURE CheckRFerror; virtual;
  8.   END;
  9.  
  10.   PROCEDURE RFtester.CheckRFerror;
  11.     { Displays some of the common errors, and waits for a keypress. }
  12.   BEGIN
  13.     IF (RFerror = 0)or(RFerror = $FFFF) then exit;
  14.     WriteLn(RFerrorString);
  15.   END;
  16.  
  17. const beep:char=#7;
  18.       inpbufsize=24*1024;
  19.       outpbufsize=18*1024;
  20.  
  21. var s,inp,outp,outp1,outp2:string;
  22.     inpf:rftester;
  23.     outpf1,outpf2:text;
  24.     inpb:array[1..inpbufsize] of char;
  25.     outpb1,outpb2:array[1..outpbufsize] of char;
  26.     len:integer;
  27.  
  28. procedure read_parameter;
  29. var code:integer;
  30.  
  31.   function open_file:boolean;
  32.   { Apre un file e ritorna il valore
  33.     FALSE se si e' verificato un errore }
  34.   var err:boolean;
  35.   begin
  36.     inpf.Init(inp, inpbufsize, inpb); { try to open the file. }
  37.     inpf.CheckRFerror;
  38.     err:=(inpf.RFerror<>0);
  39.     if err then writeln('Error opening ',inp,'!',beep);
  40.     open_file:=not(Err);
  41.   end;
  42.  
  43.   function create_file:boolean;
  44.   var err:boolean;
  45.   begin
  46.     code:=pos('.',outp);
  47.     if code<>0 then begin
  48.       outp1:=copy(outp,1,code)+'LFT';
  49.       outp2:=copy(outp,1,code)+'RGT';
  50.     end else begin
  51.       outp1:=outp+'.LFT';
  52.       outp2:=outp+'.RGT';
  53.     end;
  54.     assign(outpf1,outp1);
  55.     (*$i-*)
  56.       rewrite(outpf1);
  57.     (*$i+*)
  58.     err:=(ioresult<>0);
  59.     if err then writeln('Error creating ',inp,'!',beep) else begin
  60.       settextbuf(outpf1,outpb1);
  61.       assign(outpf2,outp2);
  62.       (*$i-*)
  63.         rewrite(outpf2);
  64.       (*$i+*)
  65.       err:=(ioresult<>0);
  66.       if err then begin
  67.         close(outpf1);
  68.         erase(outpf1);
  69.         writeln('Error creating ',inp,'!',beep);
  70.       end else settextbuf(outpf2,outpb2);
  71.     end;
  72.     create_file:=not(err);
  73.   end;
  74.  
  75. begin
  76.   inp:=paramstr(2);
  77.   while (not(open_file)) do begin
  78.     write('Input File Name (with extension) : ');
  79.     readln(inp);
  80.   end;
  81.   outp:=inp;
  82.   while(not(create_file)) do begin
  83.     write('Output File Name (without extension) : ');
  84.     readln(outp);
  85.   end;
  86.   val(paramstr(1),len,code);
  87.   while ((code<>0) or (len=0)) do begin
  88.     writeln('Wrong column number!');
  89.     write('Cut after how many character ? ');
  90.     readln(len);
  91.   end;
  92. end;
  93.  
  94. procedure screen;
  95. begin
  96.   writeln('Cut File v 1.2 - (c) 1991 Francesco Duranti');
  97.   if paramcount<>2 then begin
  98.     writeln;
  99.     writeln('Usage:');
  100.     writeln('      CUT [n] [file.ext]');
  101.     writeln;
  102.     writeln('Cut [file.ext] in two file.');
  103.     writeln('Save column 1..n in [file.LFT]');
  104.     writeln('Save column n+1..endline in [file.RGT]');
  105.     halt(1);
  106.   end;
  107.   writeln;
  108. end;
  109.  
  110. procedure read_notab(var i:rftester;var t:string);
  111. var l:integer;
  112.  
  113.   function spacestr(a:integer):string;
  114.   var b:string;
  115.       i:integer;
  116.   begin
  117.     for i:=1 to a do b:=b+' ';
  118.     spacestr:=b;
  119.   end;
  120.  
  121.   function posiz(var a:integer;b,c:string):boolean;
  122.   begin
  123.     a:=pos(b,c);
  124.     posiz:=(a<>0);
  125.   end;
  126.  
  127. begin
  128.   i.freadln(t);
  129.   while (posiz(l,#9,s)) do
  130.     t:=copy(t,1,l)+spacestr(8-(l mod 8))+copy(t,l+1,length(t)-l);
  131. end;
  132.  
  133. begin
  134.   screen;
  135.   read_parameter;
  136.   while (inpf.RFerror=0) do begin
  137.     read_notab(inpf,s);
  138.     if len>=length(s) then begin
  139.       writeln(outpf1,s);
  140.       writeln(outpf2);
  141.     end else begin
  142.       writeln(outpf1,copy(s,1,len));
  143.       writeln(outpf2,copy(s,len+1,length(s)-len));
  144.     end;
  145.   end;
  146.   inpf.done;
  147.   close(outpf1);
  148.   close(outpf2);
  149. end.
  150.