[Back to MAIL SWAG index] [Back to Main SWAG index] [Original]

    program MSGNUM;
    uses dos,crt;
    const version='v1.5';
    var sto,
        sfrom,
        daystosave,
        top,
        bottom,
        mtop,
        mbottom,
        keep      :word;
        drv       :byte;
        st,
        path      :string;
        msg,
        save      :array[1..10240] of boolean;
        date      :array[1..10240] of word;

    Function CurrentDrive:char;
    var pthstr:pathstr;
    begin
       pthstr:=fexpand('');
       CurrentDrive:=pthstr[1];
    end;

    function mchr(n:byte;ch:char):string;
    var a:byte;s:string;
    begin
      s:='';
      for a:=1 to n do s:=s+ch;
      mchr:=s;
    end;

    function FDayOfYear(l:longint):word;
    var t:datetime;
    begin
       unpacktime(l,t);
       t.month:=t.month-1;
       FDayOfYear:=((t.year-1990)*365)
       + (t.year-1988 div 4)
       + (t.month*30) + t.day
       + (  ord(t.month>=1))
       - (2*ord(t.month>=2))
       + (  ord(t.month>=3))
       + (  ord(t.month>=5))
       + (  ord(t.month>=7))
       + (  ord(t.month>=8))
       + (  ord(t.month>=10));
    end;

    Function TodaysDate:word;
    var y,m,d,temp:word;dt:datetime;l:longint;
    begin
          getdate(y,m,d,temp);
          dt.year:=y;
          dt.month:=m;
          dt.day:=d;
          packtime(dt,l);
          todaysdate:=fdayofyear(l);
    end;

    procedure initvars;
    var a:word;
    begin
       sto:=1;
       sfrom:=1;
       daystosave:=2;
       keep:=100;
       bottom:=1;
       mbottom:=1;
       mtop:=1;
       top:=1;
       path:='';
       for a:=1 to 10240 do
       begin
          msg[a]:=FALSE;
          save[a]:=FALSE;
          date[a]:=0;
       end;
    end;

    procedure getparams;
    var a,b,code:word;parama,temp:string;past:boolean;
    begin
       If (paramcount<1) or (paramstr(1)='?') then
       begin
          writeln;
          writeln(' MSGNUM ',version,' -  A Message base renumbering system for
    FIDOnet and compatible');      writeln(' message systems.  This is a brute
    force handler that is s-l-o-w. But it');      writeln(' uses file handlers
    instead of FCBs like RENUM, so is safer. Syntax:');      writeln;
          writeln('    MSGNUM  [switches] [path]');
          writeln;
          writeln(' Switches:');
          writeln;
          writeln('    /Sxx-yy    Save messages xx to yy - keeps those messages
    exactly as');      writeln('               they were before, and does NOT
    renumber THEM');      writeln('    /Dxx       Messages less than xx days old
    will be saved even if they');      writeln('               exceed the /L
    paramater');      writeln('    /Kxx       Keeps xx messages in the base, even
    if they are older than the');      writeln('               number of days
    specified in the /D paramater.');      writeln;
          writeln(' Path MUST be specified.  The path refers to the subdir of the
    base to be');      writeln(' renumbered.');
          writeln;
          writeln(' Default is:  MSGNUM /S1-1 /D2 /K100 [path]');
          halt;
       end
       else
       begin
          for a:=1 to paramcount do
          begin
             parama:=paramstr(a);
             If parama[1]='/' then
             begin
                Case upcase(parama[2]) of
                'S':begin
                       past:=FALSE;
                       temp:='';
                       for b:=3 to length(parama) do
                       begin
                          If parama[b]='-' then
                          begin
                             past:=TRUE;
                             val(temp,sfrom,code);
                             temp:='';
                          end
                          else
                          begin
                             temp:=temp+parama[b];
                          end;
                       end;
                       val(temp,sto,code);
                    end;
                'D':begin
                       temp:='';
                       for b:=3 to length(parama) do
                       begin
                          temp:=temp+parama[b];
                       end;
                       val(temp,daystosave,code);
                    end;
                'K':begin
                       temp:='';
                       for b:=3 to length(parama) do
                       begin
                          temp:=temp+parama[b];
                       end;
                       val(temp,keep,code);
                    end;
                end;
             end
             else
             begin
                If path='' then
                   for b:=1 to length(parama) do path:=path+parama[b];
                If path[length(path)]<>'\' then path:=path+'\';
                path:=fexpand(path);
             end;
          end;
       end;
    end;

    procedure readfilesin;
    var s:searchrec;
        tempword:word;
        tempint:integer;
    begin
       Findfirst(path+'*.msg',AnyFile,s);
       While DosError=0 do
       begin
          val(copy(s.name,1,length(s.name)-4),tempword,tempint);
          msg[tempword]:=TRUE;
          save[tempword]:=(tempword>=sfrom) and (tempword<=sto);
          date[tempword]:=FDayOfYear(s.time);
          If tempword<bottom then bottom:=tempword;
          If tempword>top then top:=tempword;
          Findnext(s);
       end;
    end;

    procedure findkeep;
    var count:word;td:word;
    begin
       count:=1;
       mtop:=top;
       mbottom:=top+1;
       td:=todaysdate;
       repeat
          dec(mbottom);
          If (msg[mbottom]) and (not save[mbottom]) and (mbottom>bottom) then
             inc(count);
       until ((count>=keep) and (date[mbottom]+daystosave<=td)) or
    (mbottom<=bottom);end;

    procedure deleteunwanted;
    var a,
        todayyear,
        y,
        m,
        d,
        temp    :word;
        tempstr :string[12];
        f       :file;
    begin
       Write('Erasing  No Files!  ');
       for a:=1 to (mbottom-1) do
       begin
          If (msg[a]) and (not save[a]) then
          begin
             str(a,tempstr);
             tempstr:=tempstr+'.MSG';
             assign(f,tempstr);
             Write(mchr(12,#8),mchr(12-length(tempstr),#32)+tempstr);
             erase(f);
             msg[a]:=FALSE;
          end;
       end;
       Writeln(mchr(70-wherex,#32),' ...Done.');
    end;

    procedure renameexisting;
    var a,count:word;
        tempstr,countstr:string[12];
        f:file;
    begin
       a:=mbottom;
       count:=0;
       Write('Renaming '+mchr(28,#32));
       repeat
          If (msg[a]) and (not save[a]) then
          begin
             tempstr:='';
             str(a,tempstr);
             tempstr:=tempstr+'.MSG';
             assign(f,tempstr);
             inc(count);
             while save[count] do inc(count);
             str(count,countstr);
             countstr:=countstr+'.MSG';
             Write(mchr(28,#8),tempstr,' to
    ',countstr,mchr(24-length(tempstr)-length(countstr),#32));         If
    (countstr<>tempstr) then rename(f,countstr);      end;
          inc(a);
       until a>top;
       writeln(mchr(70-wherex,#32),' ...Done.');
    end;

    begin
       initvars;
       getparams;
       getdir(0,st);
       chdir(copy(path,1,length(path)-1));
       writeln(' Renumbering directory '+copy(path,1,length(path)-1));
       readfilesin;
       findkeep;
       write(' Deleting Unwanted files.... ');
       deleteunwanted;
       write(' Renaming Remaining files... ');
       renameexisting;
       chdir(st);
    end.

[Back to MAIL SWAG index] [Back to Main SWAG index] [Original]