home *** CD-ROM | disk | FTP | other *** search
/ High Voltage Shareware / high1.zip / high1 / DIR4 / RDUP100.ZIP / RDUP.PAS < prev    next >
Pascal/Delphi Source File  |  1993-10-07  |  6KB  |  249 lines
  1. {$M 16384, 0, 0}
  2. uses dos,crt ;
  3. const
  4.      tmpd = 'rdup#dir';
  5.      masf = 'rdup#fil';
  6.      attn = 'δ∞≤▐╙▄√ΣΣ NEXT LINE STARTS NEW FILE!';
  7.  
  8. procedure showhelp ( errornum : byte );
  9. const
  10.      progdata = 'RDUP- Free DOS utility: delete duplicate lines across multiple files.';
  11.      progdat2 = 'V1.00: October 07, 1993. (c) 1993 by David Daniel Anderson - Reign Ware.';
  12.       usage   = 'Usage:  RDUP file_spec [/i (=case Insensitive)]';
  13. var
  14.     message : string [80];
  15. begin
  16.     writeln ( progdata );
  17.     writeln ( progdat2 );
  18.     writeln ;
  19.     writeln ( usage );
  20.     writeln ;
  21.  
  22.     case errornum of
  23.       1 : message := 'invalid number of command line parameters.';
  24.       2 : message := 'unable to create or use storage directory.';
  25.       3 : message := 'no files found to process.';
  26.       9 : message := 'undefined error.';
  27.     end;
  28.     writeln ( 'ERROR: (#',errornum,') - ', message );
  29.     halt ( errornum );
  30. end;
  31.  
  32. function converttoupper(w : string) : string;
  33. var
  34.    cp  : integer;        {the position of the character to change.}
  35. begin
  36.      for cp := 1 to length(w) do
  37.          w[cp] := upcase(w[cp]);
  38.      converttoupper := w;
  39. end;
  40.  
  41. procedure makedir ( tdir : string );
  42. var
  43.   resp : char ;
  44. begin
  45.   {$I-}
  46.   mkdir ( tdir );
  47.   if (IOResult <> 0) then begin
  48.      writeln ( 'Storage directory ',tdir,' already exists!' );
  49.      write ( 'Press "y" to use, any other key to abort: ');
  50.      resp := readkey ;
  51.      if (upcase (resp) <> 'Y') then showhelp (2);
  52.      writeln ( resp );
  53.   end;
  54.   {$I+}
  55. end;
  56.  
  57. procedure combine ( tagfiles : string ; var alltg : text );
  58. var
  59.    dirinfo : searchrec ;
  60.    tagline : string ;
  61.    tagfile : text ;
  62. begin
  63.   findfirst ( tagfiles, archive, dirinfo );
  64.   if ( doserror = 0 ) then begin
  65.      assign ( alltg, tmpd+'\'+masf );
  66.      rewrite ( alltg );
  67.      repeat
  68.        assign ( tagfile, dirinfo.name );
  69.        reset  ( tagfile );
  70.        writeln ( alltg,attn );
  71.        writeln ( alltg,dirinfo.name );
  72.        writeln ( 'Assimilating: ',dirinfo.name );
  73.        while   ( not ( eof ( tagfile ))) do begin
  74.             readln ( tagfile, tagline );
  75.             writeln ( alltg, tagline );
  76.        end;
  77.        close  ( tagfile );
  78.        findnext ( dirinfo );
  79.      until ( doserror <> 0 );
  80.      close ( alltg );
  81.   end
  82.   else
  83.     showhelp (3);
  84. end;
  85.  
  86. procedure separate ( var alltg : text );
  87. var
  88.    tagfiles, tagline : string ;
  89.    tagfile           : text ;
  90. begin
  91.   reset ( alltg );
  92.   readln ( alltg, tagline );
  93.   if (tagline <> attn) then
  94.     showhelp (9)
  95.   else begin
  96.     readln ( alltg, tagline );
  97.     assign ( tagfile, tagline );
  98.     writeln ( 'De-assimilating: ',tagline );
  99.     rewrite ( tagfile );
  100.   end;
  101.   while ( not ( eof ( alltg ))) do begin
  102.     readln ( alltg, tagline );
  103.     if (tagline = attn) then begin
  104.       close  ( tagfile );
  105.       readln ( alltg, tagline );
  106.       assign ( tagfile, tagline );
  107.       writeln ( 'De-Assimilating: ',tagline );
  108.       rewrite ( tagfile );
  109.     end
  110.     else
  111.       writeln ( tagfile, tagline );
  112.   end;
  113.   close  ( tagfile );
  114.   close  ( alltg );
  115. end;
  116.  
  117. procedure putnumb ( var source : text ; fname : string );
  118. var
  119.    numb  : word ;
  120.    dest  : text ;
  121.    linec : string ;
  122. begin
  123.      assign ( source, fname );
  124.      reset  ( source );
  125.      assign ( dest, 'rwgibber.tmp' );
  126.      rewrite ( dest );
  127.      numb := 10000 ;
  128.      repeat
  129.           readln (source,linec);
  130.           numb := succ (numb);
  131.           writeln ( dest, numb ,' ', linec);
  132.      until eof (source);
  133.      close ( source );
  134.      close ( dest );
  135.      erase ( source );
  136.      rename ( dest, fname );
  137. end;
  138.  
  139. procedure rmvnumb ( var source : text ; fname : string );
  140. var
  141.    dest  : text ;
  142.    linec : string ;
  143. begin
  144.      assign ( source, fname );
  145.      reset  ( source );
  146.      assign ( dest, 'rwgibber.tmp' );
  147.      rewrite ( dest );
  148.      repeat
  149.           readln ( source, linec );
  150.           delete ( linec,1,6);
  151.           writeln ( dest,linec );
  152.      until eof ( source );
  153.      close ( source );
  154.      close ( dest );
  155.      erase ( source );
  156.      rename ( dest, fname );
  157. end;
  158.  
  159. procedure dduplins ( var sfile : text ; fname : string );
  160. const dischars = 6;
  161. var
  162.    dfile  : text ;
  163.    linecr, lineca,
  164.    linenx, linena : string ;
  165.    ig_case : boolean ;
  166.    ic : string [4];
  167.  
  168. begin
  169.      if ( paramcount = 2 ) then
  170.         ig_case := (( converttoupper ( paramstr (2) )) = '/I' )
  171.      else ig_case := false ;
  172.      if ig_case
  173.         then ic := ''
  174.         else ic := 'not ';
  175.  
  176.      writeln ( 'Deleting duplicates now, and ',ic,'ignoring case.' );
  177.  
  178.      assign ( sfile, fname );
  179.      reset  ( sfile );
  180.      assign ( dfile, 'rwgibber.tmp' );
  181.      rewrite ( dfile );
  182.  
  183.      readln  ( sfile,linenx );
  184.      linena  := linenx;
  185.      if ig_case then
  186.         linena  := converttoupper (linena);
  187.      delete ( linena,1,dischars );
  188.  
  189.      while not eof (sfile) do
  190.      begin
  191.            linecr := linenx;
  192.            lineca := linena;
  193.  
  194.            readln  ( sfile,linenx );
  195.            linena  := linenx;
  196.            if ig_case then
  197.               linena  := converttoupper (linena);
  198.            delete  ( linena,1,dischars );
  199.  
  200.            if (( lineca <> linena ) or ( lineca = attn )) then
  201.               writeln ( dfile,linecr );
  202.      end;
  203.      writeln ( dfile,linenx );
  204.  
  205.      close ( sfile );
  206.      close ( dfile );
  207.      erase ( sfile );
  208.      rename ( dfile, fname );
  209. end;
  210.  
  211. var
  212.    tags    : string ;
  213.    alltags : text ;
  214.  
  215. begin
  216.   checkbreak := false ;
  217.   if ( paramcount < 1 )
  218.   or ( paramcount > 2 )
  219.      then showhelp (1);
  220.   makedir ( tmpd );
  221.   tags := paramstr (1);
  222.  
  223.   clrscr ;
  224.   writeln ( 'Start!' );
  225.   writeln ( 'Constructing master file.' );
  226.   combine ( tags, alltags );
  227.   chdir ( tmpd );
  228.   writeln ( 'Adding line numbers.' );
  229.   putnumb ( alltags, masf );
  230.  
  231.   writeln ( 'Shelling out to sort.' );
  232.    swapvectors ;
  233.    exec ( getenv ('COMSPEC'),' /c rdupsort '+masf+' >nul' );
  234.    swapvectors ;
  235.  
  236.   dduplins ( alltags, masf );
  237.  
  238.   writeln ( 'Shelling out to sort.' );
  239.    swapvectors ;
  240.    exec ( getenv ('COMSPEC'),' /c rdupsort '+masf+' /u >nul' );
  241.    swapvectors ;
  242.  
  243.   writeln ( 'Removing line numbers.' );
  244.   rmvnumb ( alltags, masf );
  245.   separate ( alltags );
  246.   writeln ( 'Destroying master file.' );
  247.   writeln ( 'Finish!' );
  248. end.
  249.