{*****************************************************************
*                                                                *
*                       Alta M. Paul                             *
*                       January, 1988                            *
*                                                                *
******************************************************************

This program normally resides in the BB manager's area.  It must be
carefully edited to reflect the current location of all the data
base files and the category and file names for each installation.

After running this program, the BB manager should log onto each
category area account and use ADDBAD3.COM to add any messages that
where not added during the previous ARPA run and then run the count
program manually to update the counts to reflect the new totals.  It
is very important to remember to do this because the users become
very confused when the counts are off for an entire day.  It is best
to attempt this archive procedure during low use times if possible.

This program is to be used for a weekly archive of any messages that
are over 30 days old.  A linked list is built of all board topics.
The user then has several alternatives for choosing the method of
archiving.

  1. Archive all boards by same date.
     A date is requested and any boards that have messages older
     than this date will be archived. Boards with no messages or
     only messages that are newer then the given date will not
     be touched.

  2. Archive selected boards by same date.
     A date is requested.  Then the program will go through
     the list of topics in the bulletin board and will query the
     user if the topic is to be archived.  If a YES is given, then
     the topic will be archived up to the given date.  If there
     are no messages or no older messages the board will not be
     touched.

  3. Archive some or all boards by specified dates.
     Each topic will be displayed.  If the user wishes to archive
     this topic an ending date will be requested. If the board contains
     messages older than this date, then the archive will be done.
     Otherwise the board will not be touched.
  
  4. No archive for this category of topics.

The Bulletin Board program should be run before executing this program
to determine which boards need to be archived and by which dates the
archives should be done.

As messages are archived, they are removed from the bulletin board.
A file called BB$ARCHIVE_FROM_todays-date.LIST will be created and will
contain the date, poster and subject of each message archived.  The
boards will be archived to sequential files with file names of the
form topic-name_ending-date.ARCHIVE.  These files should then be archived
to tape using the archive package on the system.  At the conclusion of the
archive process the data base files in use should be compressed using
the VAX/VMS CONVERT utility.  This empties the buckets and makes the data
base files more compact.  Then the old versions of the data base files can
be deleted or archived to tape.  The command for the compression is:

              CONVERT data_base_file_name data_base_file_name

Access control must be granted to the data base files before any 
of these operations can occur.

Some of the code for this program was taken from the Bulletin Board
program running NOV 1987.  The NOV 1987 Bulletin Board program contained
the option for the person running the Bulletin Board to archive the
topics if the person was a Bulletin Board manager.  The problem with
archiving the topics from the running Bulletin Board was the slowness
of this operation.  This program will archive the topics much faster
than the former archiving functions within the Bulletin Board, however,
if many messages must be archived at one time from a specific board this
program will also be quite slow.  If this program is run once a week,
the execution time should not be excessive.  Boards should not be allowed 
to exceed 300 messages.  Boards larger than this number of messages cause
the Bulletin Board program to be too slow.}



{******************************************************************}

[inherit('sys$library:starlet')]
program ArchiveMessages(input,output,bbfile,ofile,rkivefile);

const null_date = chr(0)+chr(0)+chr(0)+chr(0)+chr(0)+chr(0)+chr(0)+chr(0);
      data_logical = 'system3:[bb$program.data]';
      block_size = 512 * 3;
      date_length = 8;
      topic_length = 16;
      username_length = 48;
      subject_length = 30;
      data_length = block_size-date_length-topic_length-
                    username_length-subject_length-3;
      key_cr = chr(13);
      numbers = ['0'..'9'];
      letters = ['A'..'Z','a'..'z'];
      
type nametype = packed array [1..username_length] of char;
     timetype = packed array [1..date_length] of char;
     topictype = packed array [1..topic_length] of char;
     string = varying [data_length] of char;
     bbrec = record    {records for messages in data base file}
               date: timetype;
               topic : packed array [1..topic_length] of char;
               poster : nametype;
               subject : packed array [1..subject_length] of char;
               data : varying [data_length] of char;
               continuation : boolean;
               date_posted : timetype;
             end;
     dir_ptr = ^dirrec;
     dirrec = record       {records for topic list}
                previous : dir_ptr;
                next : dir_ptr;
                number : integer;
                date : timetype;
                topic : packed array [1..topic_length] of char;
                poster : packed array [1..username_length] of char;
                subject : packed array [1..subject_length] of char;
                class : integer;
                message_counters : record
                                     total_message : integer;
                                     new_message : integer;
                                     read_message : integer;
                                     skipped_message : integer;
                                  end;
                last_date_accessed : timetype;
               end;

var bbfile : file of bbrec;
    ofile : text;    {file for messages from one topic}
    rkivefile : text;{archive list of messages archived today}
    current_record : bbrec;
    topic_root : dir_ptr;
    topic_curr : dir_ptr;
    topic_prev : dir_ptr;
    topic_list : dir_ptr;
    topic : topictype;
    total_msgs : integer;       
    ending : packed array [1..11] of char;
    ending_date : timetype;
    delete_date : packed array [1..20] of char;
    date_string : packed array [1..20] of char;
    message_date : timetype;
    starting_date : timetype;
    line : string;
    i : integer;
    pos : integer;
    day: packed array [1..4] of char;
    month : packed array [1..3] of char;
    year : packed array [1..4] of char;
    check : integer;
    marker : integer;
    chosen_file : string;   {Added to handle splitting database. MAR-88  AMP}

{******************************************************************}

procedure create_the_dir_list;

{This procedure creates a linked list of topics from the first records
found in the data base file.}

begin
  new(topic_root);
  topic_root^.next := nil;
  topic_root^.previous := nil;

  topic_curr := topic_root;
  open(bbfile,data_logical+chosen_file,history:=old,
       access_method:=keyed,organization:=indexed,sharing:=readwrite,
       error:=continue);
  resetk(bbfile,0);   {bbfile now ready to read and write}

  repeat     {build linked list of topics}
    read(bbfile,current_record,error:=continue);
    with current_record do
    begin
      if (date = null_date) and (status(bbfile) <= 0) then
      begin
        topic_prev := topic_curr;
        new(topic_curr);
        topic_prev^.next := topic_curr;
        topic_curr^.previous := topic_prev;
        topic_curr^.topic := topic;
      end;
    end;
  until (current_record.date <> null_date) or
         eof(bbfile) or (status(bbfile) > 0);
  topic_curr^.next := nil;  {end of list points to nil}
end;


{******************************************************************}

procedure setup_archive_dir_file;

{This procedure creates and readies for writing the file that will
be a record of all archived messages from today's run.  This is a
sequential file with file name of the form:
             BB$ARCHIVE_FROM-todaysdate.LIST}

var date : packed array [1..11] of char;

begin
  $gettim(starting_date);   {today's date from system}
  $asctim(timbuf:=date_string,timadr:=starting_date); {make date look normal}
  date:=substr(date_string,1,11);   {set up date to create a file name}
  open(rkivefile,data_logical+'bb$archive_from_'+date+'.list');
  rewrite(rkivefile);    {ready file for writing}
  writeln(rkivefile,'Listing of messages archived on: ',date);
  writeln(rkivefile);
  writeln(rkivefile);
end;


{******************************************************************}

function uc(ch:string):string;

{This function changes a given string to upper case.  It is used
with some system routines that require upper case arguments.}

begin
  for i:=1 to length(ch) do 
    if ch[i] in ['a'..'z'] then ch[i]:=chr(ord(ch[i])-32);
  uc:=ch;
end;


{******************************************************************}

function invert(time:timetype):timetype;

{This function is used to make times usable in certain comparison
operations.  The system stores times in a format not suitable for
normal comparison operations.  See the system services manual for
a discussion of times and storage pertaining to VAX/VMS usage.}

var
  temp : timetype;

begin
  for i:=1 to 8 do
    temp[i]:=time[9-i];
  invert:=temp;
end;


{******************************************************************}


function change(str : string;
                index : integer) : integer;

{This function changes a numeric string into an integer.}

var i : integer;
    number : integer;

begin
  number := ord(str[1]) - 48;
  for i := 2 to index do
    number := number * 10 + (ord(str[i]) - 48);
  change := number;
end;


{******************************************************************}

function date_ok : boolean;

{This function will take the date entered by the user and check it
extensively for format and correctness.  These checks are necessary
before archiving from the data base to insure the integrity of the
messages and to insure that no run time errors occur when passing
the entered date to any of the system routines that are called.  The
author realizes that this code is not elegant and does not make use
of many features that are built in to Pascal.  However, the code will
work.}

var ok : boolean;

begin
  ok := true;
  if ((substr(ending,3,1) = '-') and (substr(ending,7,1) = '-')) then
    begin      {hyphens are in right places}
      day := substr(ending,1,2);
      if ((day[1] in numbers) and (day[2] in numbers)) then
        begin   {day is numeric}
          month := substr(ending,4,3);
          if ((month[1] in letters) and (month[2] in letters)
               and (month[3] in letters)) then
            begin    {month is alphabetic}
              year := substr(ending,8,4);
              if ((year[1] in numbers) and (year[2] in numbers) and
                  (year[3] in numbers) and (year[4] in numbers)) then
                begin   {year is numeric}
                  check := change(year,4);
                  if ((check = 1987) or (check = 1988)) then
                    begin     {year is valid}
                      month := uc(month);
                      if ((month = 'SEP') or (month = 'APR')
                            or (month = 'JUN') or (month = 'NOV')) then
                        marker := 1
                      else if ((month = 'JAN') or (month = 'MAR')
                                or (month = 'JUL') or (month = 'MAY')
                                or (month = 'AUG') or (month = 'OCT')
                                or (month = 'DEC')) then
                             marker := 2
                           else if (month = 'FEB') then
                                  marker := 3
                                else marker := 4; 
                      case (marker) of
                        1: begin  {30 days in these months}
                             check := change(day,2);
                             if ((check > 30) or (check < 0)) then
                               begin
                                 ok := false;
                                 write('Invalid day: ',day,
                                         ' for: ',month,'.');
                               end;
                           end;
                        2: begin  {31 days in these months}
                             check := change(day,2);
                             if ((check > 31) or (check < 0)) then
                               begin
                                 ok := false;
                                 write('Invalid day: ',day,
                                         'for: ',month,'.');
                               end;
                           end;
                        3: begin
                             if ((check mod 4) = 0) then
                               begin   {leap year}
                                 check := change(day,2);
                                 if ((check > 29) or (check < 0)) then
                                   begin
                                     ok := false;
                                     write('Invalid day: ',day,
                                             'for: ',month,' in a leap year.');
                                   end;
                               end
                             else
                               begin     {not a leap year}
                                 check := change(day,2);
                                 if ((check > 28) or (check < 0)) then
                                   begin
                                     ok := false;
                                     write('Invalid day: ',day,
                                             'for: ',month,'.');
                                   end;
                               end;
                           end;
                        4: begin
                             ok := false;
                             write('Invalid month: ',month,' specified.');
                           end;
                      end;   {case}               
                    end
                  else 
                    begin
                      write('Invalid year: ',year,' specified.');
                      ok := false;
                    end;
                end
              else 
                begin
                  write('Year: ',year,' must be numeric.');
                  ok := false;
                end;
             end
           else 
             begin
               write('Month: ',month,' must be alphabetic.');
               ok := false;
             end;
         end
      else 
        begin
          write('Day: ',day,' must be numeric.');  
          ok := false;
        end;
    end
  else 
    begin
      write('Hyphens misplaced in date string: ',ending,'.');
      ok := false;
    end;
  if not(ok) then writeln('  Please try again.');
  date_ok := ok;
end; 

{******************************************************************}

procedure get_end_date;

{This procedure gets the date ready for creating the output files
for archiving separate boards and also sets up the conditions
for comparisons by date that will be necessary to control the
archive process.}

var check_date : boolean;

begin
  repeat
    writeln('Enter date to archive messages THROUGH:. ');
    writeln('Date MUST be in this format:');
    writeln('dd-mmm-yyyy');
    readln(delete_date);   {this format is important!!!}
    ending := substr(delete_date,1,11);  {formats date for file name}
    check_date := date_ok;
    if (check_date = true) then
      begin
        date_string := delete_date;
        if (length(date_string) > 0) then
          if odd($bintim(timadr:=ending_date,timbuf:=uc(date_string))) then
            ending_date:=invert(ending_date);
      end;
  until (check_date = true);
end;


{******************************************************************}

procedure archive_new_topic;

{This procedure writes a heading in the file that is the archive
list of messages archived today.  This will help users find the
message they wish to locate more easily.}

var short_topic : varying [topic_length] of char;
    target : integer;

begin
  target := index(topic,' ') - 1;
  short_topic := substr(topic,1,target);
  writeln(rkivefile);
  writeln(rkivefile);
  writeln(rkivefile,'Topic is: ',topic);  
  writeln(rkivefile);
  writeln(rkivefile,'Messages stored in: ',
                     data_logical+short_topic+'_'+ending+'.archive');
  writeln(data_logical+short_topic+'_'+ending+'.archive');
  writeln(rkivefile,
           '***********************************************************');
  writeln(rkivefile);
end;


{******************************************************************}

procedure open_archive_file;

{This procedure creates the file to archive the current topic to and
readies it for writing.  The archive files are sequential files.}

begin
  open(ofile,
       data_logical+topic+'_'+ending+'.archive');
  rewrite(ofile);
end; 


{******************************************************************}

procedure extract;

{This procedure will take the data portion of the current record and
write it in 80 column format into the archive file for this topic.
Then the current record component is deleted from the data base file.}

begin
  with current_record do
  begin
    repeat
      pos:=index(data,key_cr);  {data field formatted with <CR> already}
        if pos=0 then pos:=length(data)+1;
        if pos>1 then
          line:=substr(data,1,pos-1)
        else
          line:='';
        if pos<(length(data)-1) then
          data:=substr(data,pos+2,length(data)-pos-1)
        else
          data:=''; 
        writeln(ofile,line,error:=continue);
      until length(data)=0;
  end;
  delete(bbfile);   {deletes current file component from bbfile}
end;
                          

{******************************************************************}

procedure get_header_message;

{This procedure will write a heading into the archive file for this
topic.  One heading is written for each message even though a 
message may extend over several record components.}

begin
  with current_record do
  begin
    $asctim(timbuf:=date_string,timadr:=invert(date));  {decodes the
            stored date so it can be written in normal format}
    writeln(ofile,'Date:      ',date_string,error:=continue);
    writeln(ofile,'Posted by: ',poster,error:=continue);
    writeln(ofile,'Topic:     ',topic,error:=continue);
    writeln(ofile,'Subject:   ',subject,error:=continue);
    writeln(ofile,error:=continue);
  end;
end;


{******************************************************************}

procedure get_end_message;

{This procedure puts a marker at the end of each archived message to
make the file more readable to the user.}

begin
  writeln(ofile);
  writeln(ofile);
  writeln(ofile,'************END OF MESSAGE************');
  writeln(ofile);
  writeln(ofile);
end;


{******************************************************************}

procedure archive_topic;

{This procedure will archive one selected topic up to a specific
date.}

begin
  archive_new_topic;
  repeat
    message_date := current_record.date;
    get_header_message;
    writeln(rkivefile,date_string:11,' ',current_record.poster:48,
            ' ',current_record.subject:30);
    repeat
      extract;
      get(bbfile);  {sets file pointer to next record}
      current_record := bbfile^;
    until (current_record.date <> message_date);
    get_end_message;
  until ((current_record.topic <> topic) or    
         (current_record.date > ending_date) or
         (eof(bbfile)) or
         (status(bbfile) > 0));
  close (ofile);
end;


{******************************************************************}

procedure separate_archive;

{This procedure will archive all the boards by a given date.  If a
board has no messages or no messages older than the specified date,
then no archive will be done for it.}

begin
  topic_list := topic_root;
  get_end_date;
  repeat
    topic_list := topic_list^.next;
    topic := topic_list^.topic;
    findk(bbfile,1,topic+null_date,gtr,error:=continue);
    if (not(ufb(bbfile))) then
    begin
      current_record := bbfile^;
      if ((topic = current_record.topic) and 
           (current_record.date <= ending_date)) then
      begin
        open_archive_file;
        archive_topic;
      end;
    end;
  until (topic_list^.next = nil);
end;


{******************************************************************}

procedure get_yesno(var yesno : char);

{This procedure is a query to help set up to archive separate boards
when all boards are not to be archived automatically.}

begin
  repeat
    writeln('Topic is : ',topic,
            '. Do you wish to archive this topic? [Y/N]');
    readln(yesno);
    if (not(yesno in ['Y','y','N','n'])) then
      writeln('Valid choices are Y or N');
  until (yesno in ['Y','y','N','n']);
end;


{******************************************************************}

procedure selected_archive;

{The user will be asked for an ending date.  Then each topic will
be displayed.  The user can then choose which topics to archive
by the given date.}

var yesno : char;

begin
  topic_list := topic_root;
  get_end_date;
  repeat
    yesno := ' ';
    topic_list := topic_list^.next;
    topic := topic_list^.topic;
    findk(bbfile,1,topic+null_date,gtr,error:=continue);
    if (not(ufb(bbfile))) then
    begin
      get_yesno(yesno);
      if (yesno in ['Y','y']) then
      begin
        current_record := bbfile^;
        if ((topic = current_record.topic) and
             (current_record.date <= ending_date)) then
        begin
          open_archive_file;
          archive_topic;
        end;
      end;
    end;
  until (topic_list^.next = nil);
end;


{******************************************************************}

procedure archive_all_by_date;

{This procedure will display a topic.  If it is to be archived, an
ending date will be requested.  Any or all topics may be selected.}

var yesno : char;

begin
  topic_list := topic_root;
  repeat
    yesno := ' ';
    topic_list := topic_list^.next;
    topic := topic_list^.topic;
    findk(bbfile,1,topic+null_date,gtr,error:=continue);
    if (not(ufb(bbfile))) then
    begin
      get_yesno(yesno);
      if (yesno in ['Y','y']) then
      begin
        current_record := bbfile^;
        get_end_date;      
        if ((topic = current_record.topic) and
             (current_record.date <= ending_date)) then
        begin
          open_archive_file;
          archive_topic;
        end;
      end;
    end;
  until (topic_list^.next = nil);
end;


{******************************************************************}

procedure choose_archive_method;

{This is the portion of the program that will allow the user to decide
on how the archive is to be done.}

var choose_char : char;
    valid_choice : boolean;

begin
  valid_choice := false;
  repeat
    writeln;
    writeln;
    writeln('Bulletin Board Archive Utility');
    writeln('******************************');
    writeln;
    writeln('Please choose an option from the following menu:');
    writeln;
    writeln('1. Archive all boards by same date');
    writeln;
    writeln('2. Archive selected boards by same date');
    writeln;
    writeln('3. Archive some or all boards by specific date on each board');
    writeln;
    writeln('4. Do not archive any of the topics from this category');
    writeln;
    writeln('CHOICE: ');
    readln(choose_char);
    if (choose_char in ['1','2','3','4']) then
      begin
        valid_choice := true;
        case (choose_char) of
          '1': separate_archive;
          '2': selected_archive;
          '3': archive_all_by_date;
          '4':;
        end; {case}
      end {begin}
    else
      writeln('Valid choices are 1,2,3 or 4');
    close(bbfile,error:=continue);
  until (valid_choice);
end;


{******************************************************************}

begin
  setup_archive_dir_file;
  writeln;
  writeln;
  writeln('Ready to archive local NRL topic boards:');
  chosen_file := 'bb$local_boards.dat';
  create_the_dir_list;
  choose_archive_method;


  writeln;
  writeln;
  writeln('Ready to archive bitnet boards');
  chosen_file := 'bb$bitnet_boards.dat';
  create_the_dir_list;
  choose_archive_method;


  writeln;
  writeln;
  writeln('Ready to archive research boards');
  chosen_file := 'bb$research_boards.dat';
  create_the_dir_list;
  choose_archive_method;
  close(rkivefile,error:=continue);
end.
