home *** CD-ROM | disk | FTP | other *** search
/ DP Tool Club 15 / CD_ASCQ_15_070894.iso / news / 571 / rdate120 / redate_.pas < prev    next >
Pascal/Delphi Source File  |  1993-10-19  |  8KB  |  270 lines
  1. program setfiletime;
  2. {------------------------------------------------------------------------------
  3.  
  4.                                 REVISION HISTORY
  5.  
  6. v1.00  : 1993/07/14.  First public release.  DDA
  7. v1.10  : 1993/09/07.  Added support for single field specification,
  8.                             suggestion and assistance from Don Dougherty.  DDA
  9.                       Added support for century.
  10.                             (Set century=2000 for 20th century dates.)  DDA
  11. v1.10a : 1993/09/09.  Now specifying seconds is optional, default is :00  DDA
  12. v1.11  : 1993/09/13.  Added "/p": prompt for date, time doesn't change.  DDA
  13. v1.15  : 1993/09/28.  Increased date & time specification flexibility.  DDA
  14. v1.20  : 1993/10/20.  Now can stamp files not in current directory.  DDA
  15.  
  16. ------------------------------------------------------------------------------}
  17.  
  18. uses dos ;
  19. var
  20.    dirinfo : searchrec ;
  21.    ps1     : pathstr ;
  22.    rdir    : dirstr ;
  23.    rname   : namestr ;
  24.    rext    : extstr ;
  25.    ps2     : string ;
  26.    century : word ;
  27.  
  28. procedure showhelp ( errornum : byte );
  29. const
  30.     progdata = 'REDATE!- Free DOS utility: file redater.';
  31.     progdat2 = 'V1.20: October 20, 1993. (c) 1993 by David Daniel Anderson - Reign Ware.';
  32.  
  33.     usage = 'Usage: REDATE! file(s) [mm/dd/yy (or) mm-dd-yy] [hh:mm[:ss]]';
  34.     usag2 = '  or : REDATE! file(s) /p  (prompt for date, time doesn''t change)';
  35. var
  36.     message : string [80];
  37. begin
  38.     writeln ( progdata );
  39.     writeln ( progdat2 );
  40.     writeln ;
  41.     writeln ( usage );
  42.     writeln ( usag2 );
  43.     writeln ;
  44.  
  45.     case errornum of
  46.       1 : message := 'you must specify -exactly- one filespec (wildcards are OK).';
  47.       2 : message := 'too many parameters.';
  48.       3 : message := 'non-numeric found in a date or time string!';
  49.     end;
  50.     writeln ( 'ERROR: (#',errornum,') - ', message );
  51.     halt ( errornum );
  52. end;
  53.  
  54. function leadingzero ( w : word ) : string ;
  55. var
  56.   s : string ;
  57. begin
  58.   str (w:0,s);
  59.   if length (s) = 1 then
  60.     s := '0' + s;
  61.   leadingzero := s;
  62. end;
  63.  
  64. procedure parsedate ( dates : string ; var cdt : longint );
  65. var
  66.      date_time : datetime;
  67.      valerr : integer ;
  68. begin
  69.      if ( length ( dates ) = 7 ) then
  70.         dates := '0'+dates;
  71.      with date_time do
  72.      begin
  73.           val ( copy ( dates ,1,2 ), month, valerr );
  74.               if valerr <> 0 then showhelp (3);
  75.           val ( copy ( dates ,4,2 ), day,   valerr );
  76.               if valerr <> 0 then showhelp (3);
  77.           val ( copy ( dates ,7,2 ), year,  valerr );
  78.               if valerr <> 0 then showhelp (3);
  79.           year := century + year;
  80.      end;
  81.      packtime ( date_time, cdt );
  82. end;
  83.  
  84. procedure parsetime ( times : string ; var cdt : longint );
  85. var
  86.      date_time : datetime;
  87.      valerr : integer ;
  88. begin
  89.      if (( length ( times ) = 4 )
  90.       or ( length ( times ) = 7 )) then
  91.         times := '0'+times;
  92.      if ( length ( times ) = 5 ) then
  93.         times := times + ':00' ;
  94.      with date_time do
  95.      begin
  96.           val ( copy ( times ,1,2 ), hour, valerr );
  97.               if valerr <> 0 then showhelp (3);
  98.           val ( copy ( times ,4,2 ), min,  valerr );
  99.               if valerr <> 0 then showhelp (3);
  100.           val ( copy ( times ,7,2 ), sec,  valerr );
  101.               if valerr <> 0 then showhelp (3);
  102.      end;
  103.      packtime ( date_time, cdt );
  104. end;
  105.  
  106. procedure get_dt ( var cur_dt : longint );
  107. var
  108.     y,mo,d,w,
  109.     h,mi,s,u  : word;
  110.     date_time : datetime;
  111. begin
  112.      getdate (y,mo,d,w);
  113.      gettime (h,mi,s,u);
  114.      with date_time do
  115.      begin
  116.           YEAR := y;  MONTH := mo;  DAY := d;
  117.           HOUR := h;  MIN   := mi;  SEC := s;
  118.      end;
  119.      packtime ( date_time, cur_dt );
  120. end;
  121.  
  122. function extract_file_date ( fname : string ) : string ;
  123. var
  124.     afile : file ;
  125.     fdate : longint ;
  126.     dtt   : datetime ;
  127.     dstr  : string ;
  128. begin
  129.      assign (afile, fname);
  130.      reset (afile);
  131.      getftime (afile, fdate);
  132.      close (afile);
  133.      unpacktime ( fdate, dtt );
  134.      dstr := '' ;
  135.      with dtt do begin
  136.           dstr := dstr + leadingzero ( month ) + '/' ;
  137.           dstr := dstr + leadingzero ( day ) + '/' ;
  138.           dstr := dstr + ( copy ( ( leadingzero ( year )), 3, 2 ));
  139.      end;
  140.      extract_file_date := dstr ;
  141. end;
  142.  
  143. function extract_file_time ( fname : string ) : string ;
  144. var
  145.     afile : file ;
  146.     ftime : longint ;
  147.     dtt   : datetime ;
  148.     tstr  : string ;
  149. begin
  150.      assign (afile, fname);
  151.      reset (afile);
  152.      getftime (afile, ftime);
  153.      close (afile);
  154.      unpacktime ( ftime, dtt );
  155.      tstr := '' ;
  156.      with dtt do begin
  157.           tstr := tstr + leadingzero ( hour ) + ':' ;
  158.           tstr := tstr + leadingzero ( min ) + ':' ;
  159.           tstr := tstr + leadingzero ( sec );
  160.      end;
  161.      extract_file_time := tstr ;
  162. end;
  163.  
  164. procedure stampfile ( fname : string ; ftime : longint );
  165. var
  166.    afile : file ;
  167. begin
  168.      assign (afile, rdir+fname);
  169.      reset (afile);
  170.      setftime (afile, ftime);
  171.      close (afile);
  172.      write ('.');
  173. end;
  174.  
  175. procedure todaysdate;
  176. var
  177.    dt : longint ;
  178. begin
  179.      get_dt ( dt );
  180.      while doserror = 0 do begin
  181.            stampfile ( dirinfo.name, dt );
  182.            findnext ( dirinfo );
  183.      end;
  184. end;
  185.  
  186. procedure justdate ( datestr : string );
  187. var
  188.    timestr : string ;
  189.    dt_int  : longint ;
  190. begin
  191.      parsedate ( datestr , dt_int );
  192.      while doserror = 0 do begin
  193.            timestr := extract_file_time ( dirinfo.name );
  194.            parsetime ( timestr , dt_int );
  195.            stampfile ( dirinfo.name , dt_int );
  196.            findnext ( dirinfo );
  197.      end;
  198. end;
  199.  
  200. procedure justtime ( timestr : string );
  201. var
  202.    datestr : string ;
  203.    dt_int  : longint ;
  204. begin
  205.      parsetime ( timestr , dt_int );
  206.      while doserror = 0 do begin
  207.            datestr := extract_file_date ( dirinfo.name );
  208.            parsedate ( datestr , dt_int );
  209.            stampfile ( dirinfo.name , dt_int );
  210.            findnext ( dirinfo );
  211.      end;
  212. end;
  213.  
  214. procedure newdate ( datestr, timestr : string );
  215. var
  216.    dt_int : longint ;
  217. begin
  218.      parsedate ( datestr , dt_int );
  219.      parsetime ( timestr , dt_int );
  220.      while doserror = 0 do begin
  221.            stampfile ( dirinfo.name , dt_int );
  222.            findnext ( dirinfo );
  223.      end;
  224. end;
  225.  
  226. var cent : string ;
  227.     vale : integer ;
  228.  
  229. begin
  230.      ps1 := ( fexpand ( paramstr (1) ));
  231.      fsplit ( ps1,rdir,rname,rext );
  232.      findfirst ( ps1, archive, dirinfo );
  233.      if ( doserror <> 0) then
  234.           showhelp(1);
  235.      write ( 'Working ' );
  236.  
  237.      cent := getenv ( 'century' );
  238.      if cent = '' then cent := '1900' ;
  239.      val ( cent, century, vale );
  240.      if vale <> 0 then century := 1900 ;
  241.  
  242.      case paramcount of
  243.           1 : todaysdate;
  244.           2 : begin
  245.                  ps2 := paramstr ( 2 );
  246.                  if ((ps2 = '/p') or (ps2 = '/P')) then begin
  247.                     while ( length (ps2) < 8) do begin
  248.                        writeln ;
  249.                        writeln ('Enter a date in the format mm/dd/yy:');
  250.                        readln  (ps2);
  251.                     end;
  252.                     justdate (ps2);
  253.                  end
  254.                  else begin
  255.                     if (( length (ps2) = 4 )
  256.                      or ( length (ps2) = 7 )) then
  257.                        ps2 := '0'+ps2;
  258.                     if (( ps2[3] = '-' ) or
  259.                         ( ps2[3] = '/' )) then justdate ( ps2 )
  260.                     else justtime ( ps2 );
  261.                  end;
  262.               end;
  263.           3 : newdate ( paramstr (2), paramstr (3) );
  264.      else
  265.           showhelp(2);
  266.      end;   { case }
  267.  
  268.      writeln ( ' done!' );
  269. end.
  270.