ftp.wwiv.com/ftp.wwiv.com.zip/ftp.wwiv.com/pub/MISC/MKDATE12.ZIP/makedate.pas

Pascal/Delphi Source File | 2003-06-21 | 4KB | 212 lines

program makedate;

uses
 dos, block, filedef, sublist, message, block2;

const
 numchanged: word = 0;

var
 atfile: string;
 subname: string[8];
 result: longint;
 makenew, ismulti: boolean;

 header: headertype;

procedure nextseq;
 begin
  err := 0;
  if result <> 0 then
   begin
    if result <> headerfpos then
     begin
      seek(mainsub.headerf.filevar, ((result - 1) shl 8) +
       mainsub.headerf.offset);
      err := ioresult
     end;
    if err = 0 then
     begin
      headerfpos := result;
      blockread(mainsub.headerf.filevar, header, 256);
      err := ioresult
     end;
    if err = 0 then
     inc(headerfpos)
    else
     begin
      result := 0;
      headerfpos := -1
     end
   end
 end;

procedure getnextseq;
 begin
  if header.nextseqrec = result then
   result := 0
  else
   result := header.nextseqrec;
  nextseq
 end;

procedure findhead(ix: ixtype; id: longint);
 begin
  result := findheader(header, ix, id, 0)
 end;

procedure writeback;
 begin
  writeblockfile(mainsub.headerf, result, @header);
  inc(numchanged)
 end;

procedure maindate;
 var
  msgnum, curnum, newlast: longint;
 begin
  newlast := mainsub.subinfo.firstmsg;
  if newlast < mainsub.subinfo.lastmsg then
   begin
    msgnum := newlast;
    repeat
     findhead(seq, msgnum);
     if result = 0 then
      inc(msgnum)
    until (result <> 0) or (msgnum >= mainsub.subinfo.lastmsg);

    while (result <> 0) do
     begin
      curnum := header.id[seq];
      if newlast < curnum then
       newlast := curnum;

      with header.date do
       if makenew then
        if year < 80 then
         begin
          year := year + 100;
          writeback
         end
        else
       else
        if year >= 100 then
         begin
          year := year - 100;
          writeback
         end;

      getnextseq
     end
   end
 end;

procedure setsubname(var tmp: string);
 var
  x: byte;
 begin
  subname := tmp;
  for x := 1 to length(subname) do
   subname[x] := upcase(subname[x])
 end;

procedure paramparse;
 var
  tmp: string;
  x: integer;
 begin
  if paramcount <> 2 then
   begin
    writeln('Syntax: makedate new subname');
    writeln('    or: makedate old subname');
    writeln;
    writeln('    or: makedate new @listfile');
    writeln('    or: makedate old @listfile');
    halt(1)
   end;

  tmp := paramstr(1);
  if tmp[1] = '/' then
   delete(tmp, 1, 1);
  makenew := (upcase(tmp[1]) = 'N');

  if makenew and (cf.version < 500) then
   begin
    writeln('The "new" function only works with SL 5.0 or later.');
    halt(1)
   end;

  tmp := paramstr(2);
  ismulti := (tmp[1] = '@');

  if ismulti then
   begin
    delete(tmp, 1, 1);
    atfile := tmp
   end
  else
   setsubname(tmp)
 end;

procedure onesub;
 begin
  write('Adjusting dates in ', subname, ' to ');
  if makenew then
   write('new')
  else
   write('old');
  write(' format... ');
  p := sublistroot;
  while (p <> nil) and (p^.fname <> subname) do
   p := p^.next;
  if p^.fname = subname then
   if lockopen then
    begin
     maindate;
     lockclose;
     writeln('OK')
    end
   else
    writeln('could not open')
  else
   writeln('not found');
  writeln
 end;

procedure allsubs;
 var
  list: text;
  tmp: string;
 begin
  assign(list, atfile);
  reset(list);
  repeat
   readln(list, tmp);
   setsubname(tmp);
   onesub
  until eof(list);
  close(list)
 end;

begin
 writeln('Makedate for Searchlight v1.2');
 writeln('Copyright (c) 2003 William McBrine');
 writeln;
 if openfiles([configf]) then
  begin
   closeallfiles;
   paramparse;

   sublistinit(subboards);

   if ismulti then
    allsubs
   else
    onesub;

   writeln(numchanged, ' messages updated')
  end
 else
  writeln('Could not open CONFIG File')
end.