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