home *** CD-ROM | disk | FTP | other *** search
/ CP/M / CPM_CDROM.iso / lambda / soundpot / p / split45.lbr / SPLIT45.PZS / SPLIT45.PAS
Encoding:
Pascal/Delphi Source File  |  1993-10-25  |  9.5 KB  |  280 lines
  1.  
  2. Program split45;            { 03/20/87,  by M. Dingacci }
  3. {
  4. Compiler end addresses:
  5.  
  6. 16k buffer: | 24k buffer:
  7. ----------- | -----------
  8. 7646 (v3.0) | 9646 (v3.0)
  9. 751F (v2.0) | 951F (v2.0)
  10. 72C3 (v1.0) | 92C3 (v1.0)
  11. }
  12.  
  13. Type
  14.   filstr = String[20];      { define type for filenames }
  15.  
  16. Const
  17.   buffrecs = 128;           { 16k buffer,   192 for 24k }
  18.   buffsize = 16384;         {             24576 for 24k }
  19.   version  = 'SPLIT v4.5';
  20.   date     = '(03/20/87)';
  21. Var
  22.   dotpos,colonpos,
  23.   ltr,endrec,i,z,s,
  24.   linesperfile       : Integer;
  25.   exten              : Real;
  26.   bigbuff            : Array[1..buffsize] Of Byte;  { bytes in buffer }
  27.   fnm1,fnm2          : filstr;
  28.   filvar,filvar2     : File;
  29.   basename,extenstr  : String[9];
  30.   yn,yn2             : Char;
  31.   oldtxfil,newtxfil  : Text;
  32.   flag,cflag         : Boolean;
  33.  
  34. Procedure header;    { program & version ID }
  35.   Begin
  36.     Writeln(^m^j,version,' -- ',(buffrecs/8):0:2,'k buffer.');
  37.     Writeln(date,' -- Splits a file by records, lines, or files.'^m^j);
  38.   End;
  39.  
  40. Procedure parse;     { parse command line   }
  41.   Var
  42.     cmdln   :Integer;
  43.     cmdline : filstr Absolute $80; { command tail at 80 hex }
  44.   Begin
  45.     fnm1 := ''; fnm2 := ''; { zero variables    }
  46.     i := 0; z := 0;
  47.     ltr := Length(cmdline); { Ltr = # of chars  }
  48.     While i < ltr Do Begin  { build ParamStr(1) }
  49.       i := i+1;             { (could build 2, 3, etc.)   }
  50.       If z = 1 Then If cmdline[i] <> ' ' Then fnm1 := fnm1 + cmdline[i];
  51.       If cmdline[i] = ' ' Then z := z + 1;
  52.     End;
  53.   End;
  54.  
  55. Procedure sysreset;
  56.   Begin
  57.     If (flag) And (exten<>0) Then Begin
  58.     Write('change destination disk & press RETURN ');
  59.     Readln(extenstr);
  60.  
  61.     { reset default drive to allow changing destination disk }
  62.  
  63.     ltr:=Bdos($19);  { get default drive name  }
  64.     Bdos($0d);       { reset disk drive system }
  65.     Bdos($0e,ltr);   { select drive for r/w    }
  66.     End;
  67.   End;
  68.  
  69. Procedure chekfile(Var fnm0:filstr);
  70.   Begin
  71.     If fnm0 = '' Then Halt;        { end if blank           }
  72.     dotpos:= Pos('.',fnm0)-1;      { find dot in file name  }
  73.     If dotpos < 0
  74.       Then dotpos := Length(fnm0); { dot omitted position   }
  75.     For i:=1 To Length(fnm0)
  76.       Do fnm0[i]:=Upcase(fnm0[i]); { capitalize }
  77.     colonpos:=Pos(':',fnm0);       { locate colon for drive }
  78.     basename[0] := Chr(dotpos);    { parse out base name    }
  79.     For i := 1 To dotpos Do basename[i] := fnm0[i];
  80.     flag:=(cflag);
  81.     If Not flag Then cflag := (colonpos = 2);
  82.     If ((colonpos<>0) And (colonpos<>2))
  83.       Or (Length(basename)-(colonpos)>8)
  84.       Or (Length(fnm0)-Length(basename)>4)
  85.       Then Begin
  86.       Writeln('Bad File Name'^m^j^g); { name invalid, try again }
  87.       fnm0 :='';
  88.     End;
  89.   End; {chekfile}
  90.  
  91. Procedure assignfile;
  92.   Begin
  93.     While fnm1 = '' Do Begin
  94.       Write('Source File Name (RETURN aborts): ');
  95.       Readln(fnm1);             { filename prompt      }
  96.       chekfile(fnm1);           { check valid name     }
  97.     End;
  98.     Assign(filvar,fnm1);        { assign source file   }
  99.     {$I-} Reset(filvar); {$I+}  { open file            }
  100.     If Ioresult = 1 Then Begin  { not found, try again }
  101.       Writeln;
  102.       Writeln('"',fnm1,'" Not Found!'^g);
  103.       Writeln;
  104.       fnm1 := ''; assignfile;
  105.     End;
  106.   End; {assignfile}
  107.  
  108. Procedure ioerr; { check for full disk/dir }
  109.   Begin
  110.     Case Ioresult Of
  111.       $f0 : Begin; Writeln(^m^j'Disk Full!'^g);
  112.             Close(filvar2); Close(newtxfil);
  113.             Halt ; End;
  114.       $f1 : Begin; Writeln(^m^j'Directory Full!'^g); Halt; End;
  115.     End;
  116.   End;
  117.  
  118. Procedure assignfile2;
  119.   Begin
  120.  
  121.     Reset(filvar);              { reset source & tell size }
  122.     Writeln(fnm1,' has ',Filesize(filvar):3,' records of 128 bytes each.'^m^j);
  123.     If Filesize(filvar)<2 Then Halt;
  124.     While fnm2='' Do Begin
  125.       Write('Basename for destination files          : ');
  126.       Readln(fnm2);
  127.       chekfile(fnm2);
  128.     End;
  129.     Write('Use the "Auto-split" option?   (Y or N) : ');
  130.     Read(Kbd,yn); yn:=Upcase(yn);Writeln(yn);
  131.     If cflag Then Begin         { reset option if ":" in name }
  132.       Write('System reset for each new file? (Y or N): ');
  133.       Read(Kbd,yn2);Writeln(Upcase(yn2));
  134.       flag := (Upcase(yn2) = 'Y');
  135.     End;
  136.     yn2:=' ';
  137.     If yn='Y' Then While Not (yn2 In ['R','F','L']) Do Begin
  138.       Write('Split by (R)ecords, (F)iles, or (L)ines : ');
  139.       Read(Kbd,yn2);
  140.       yn2:=Upcase(yn2);
  141.       Writeln(yn2);
  142.     End;
  143.     i:=0;
  144.     Case yn2 Of                 { auto-split "case" routine }
  145.     'F' : Begin
  146.       Write('Number of files to split source into    : ');
  147.       Readln(i); If i=0 Then Halt;
  148.       If i>Filesize(filvar) Then i:=Filesize(filvar);
  149.       s:=Filesize(filvar) Div i
  150.     End;
  151.     'R' : Begin
  152.       Write('Number of records per destination file  : ');
  153.       Readln(i); If i=0 Then Halt;
  154.       If i>Filesize(filvar) Then i:=Filesize(filvar);
  155.       s:=i;
  156.     End;
  157.     'L' : Begin
  158.       exten := 0.001;
  159.       linesperfile:=0;
  160.       Assign(oldtxfil,fnm1);
  161.       Reset(oldtxfil);
  162.       Write('Number of lines per destination file    : ');
  163.       Readln(linesperfile);If linesperfile < 1 Then Halt;
  164.       Str(exten:0:3,extenstr);
  165.       extenstr:=Copy(extenstr,2,4);
  166.       fnm2:= basename + extenstr;
  167.       Assign(newtxfil, fnm2);
  168.       {I-} Rewrite(newtxfil); {I+} { open/overwrite output file }
  169.       ioerr;
  170.       Writeln(^m^j'Creating ',fnm2);
  171.     End;
  172.     End; {case}
  173. End; {assignfile2}
  174.  
  175. Procedure splitbinfil;
  176.   Begin
  177.     exten:= 0;
  178.     ltr  := 0;
  179.     endrec:=0;
  180.     While Not Eof(filvar) Do Begin
  181.       sysreset;
  182.       If (yn<>'Y') Then Begin
  183.         Write(^m^j'Output file extension number? (1 to 999): ');
  184.         if ltr<>0 then ltr:=ltr+1;
  185.         Readln(ltr);
  186.         if ltr=0 then halt;
  187.         exten:=(ltr-1)*0.001;
  188.         Write('Begin at which source record? (0 to ',filesize(filvar):3,
  189.         '): ');
  190.         if endrec<>0 then endrec:=endrec+1;
  191.         Readln(endrec);        { start of block }
  192.         seek(filvar,endrec);
  193.         Write('Copy thru which record? (0=abort/CR=EOF): ');
  194.         Readln(endrec);        { end of block   }
  195.         if endrec=0 then halt;
  196.       End Else endrec:=endrec+s;
  197.       If (Trunc(exten*1000+0.5)>=(i-1)) And (yn2='F') Then endrec := 0;
  198.       If endrec>Filesize(filvar) Then endrec:=Filesize(filvar);{set end of }
  199.       If endrec<=Filepos(filvar) Then endrec:=Filesize(filvar);{split block}
  200.       exten:=exten+0.001;           { index extension  }
  201.       Str(exten:0:3,extenstr);      { change to string }
  202.       extenstr:=Copy(extenstr,2,4); { drop leading zero}
  203.       fnm2:=basename+extenstr;      { add to basename  }
  204.       Writeln(^m^j'Creating file ',fnm2);
  205.       Assign(filvar2,fnm2);
  206.       {$I-} Rewrite(filvar2); {$I+}
  207.       ioerr;                           { check for disk full   }
  208.       While (Not Eof(filvar)) And (endrec > Filepos(filvar)) Do Begin
  209.         z:=endrec-Filepos(filvar);     { calc # of blocks left }
  210.         If (z < buffrecs) And (z>0) Then Begin
  211.           Write(^m'Copying Records: ',filepos(filvar),'-',filepos(filvar)+z);
  212.           Blockread(filvar,bigbuff,z); { write all remaining records }
  213.                                        { if less than buffrecs left  }
  214.           {$I-} Blockwrite(filvar2,bigbuff,z); {$I+}
  215.           ioerr;                       { check disk }
  216.         End Else                       { write buffrecs records if }
  217.         Begin                          { more than buffrecs remain }
  218.           Write(^m'Copying Records: ',filepos(filvar),
  219.                                       '-',Filepos(filvar)+buffrecs);
  220.           Blockread(filvar,bigbuff,buffrecs);
  221.           {$I-} Blockwrite(filvar2,bigbuff,buffrecs); {$I+}
  222.           ioerr;                       { check disk }
  223.         End;
  224.       End;
  225.       Close(filvar2);
  226.       Writeln;
  227.     End;
  228.     Close(filvar2);
  229.     Close(filvar);
  230.  
  231.   End; {splitbinfil}
  232.  
  233. Procedure splittxtfile; { From identical procedure in CHOP18.PAS }
  234.   Var
  235.     count,totallines : Integer;
  236.     thisline         : String[255];
  237.   Begin
  238.   totallines:=0;
  239.   While Not Eof(oldtxfil) Do
  240.     Begin
  241.       For count:= 1 To linesperfile Do Begin
  242.         Readln(oldtxfil, thisline);
  243.         {I-} Writeln(newtxfil, thisline); {I+}
  244.         ioerr;
  245.         totallines := totallines + 1;
  246.         Write(totallines,' lines'^m);
  247.         If Eof(oldtxfil) Then Begin
  248.           Close(newtxfil);
  249.           Writeln;Writeln;
  250.           Writeln(^g,totallines,' total lines processed!');
  251.           Halt;
  252.         End;
  253.       End;
  254.       If Not Eof(oldtxfil) Then Begin
  255.         Close(newtxfil);            { see comments in binary }
  256.         exten:= exten + 0.001;      { file routine above     }
  257.         Str(exten:0:3, extenstr);
  258.         extenstr:=Copy(extenstr,2,4);
  259.         fnm2:= basename + extenstr;
  260.         Writeln; sysreset;
  261.         Assign(newtxfil, fnm2);
  262.         {I-} Rewrite(newtxfil); {I+}
  263.         ioerr;
  264.         Writeln(^m^j'Creating ',fnm2);
  265.       End;     {if not eof}
  266.     End;
  267.     Close(newtxfil);
  268.   End;
  269.  
  270. Begin
  271.   parse;                       { parse command tail for source name}
  272.   header;                      { program, version, and buffer size }
  273.   cflag:=False;                { initially set no ":" in filename  }
  274.   assignfile;                  { assign and verify source filename }
  275.   assignfile2;                 { create & write split output files }
  276.   If yn2='L' Then splittxtfile { text files by lines per new file  }
  277.              Else splitbinfil; { any file by records per new file  }
  278.   Writeln('Done.');
  279. End.
  280.