{This program resides in each of the category mail areas and must be
edited to reflect the proper data base file to write messages to.

This program was originally written by Charles Brown.  It was commented 
and formatted by Alta Paul in January, 1988.  Although the code could be 
much simplified, it does work in the present format.  Many of the log 
messages have been changed in order to be more descriptive and to document 
where the message originated.  These messages are written to file 
BB$NEWMAIL3.LOG during the 3a.m. run to add messages to the bulletin board data 
base and to the screen during the daily invocation of the ADDBAD3.COM 
procedure.  

There are a few problems with this program and I have attempted 
to solve them where time permitted and to document them if they were not 
solved.  As the program now stands, any message that cannot be added 
successfully to the data base is retained as a text file with the name of 
BB$BAD_MAIL.TXT

There are many reasons why messages cannot be added.  

* The most common error in the log file will concern doubling of messages.  
The FDL for the data base file does not allow for any message to reside in 
the date base more than one time.  This helps to keep the data base of a 
smaller size since often we get "message bounce" on the network and receive 
multiple copies of messages for the BITNET topics.  The code has been 
changed when a doubling occurs to delete the file rather than have it stay 
around for inspection by the bulletin board manager when ADDBAD3.COM is run.

* Another common problem occurs with the header created at the time of 
mailing or when the message is extracted from the mail utility.  I have 
been unable to solve some of these problems.  Things that can be tried to 
add messages that seem to be malformed:

  - invoke the editor on the malformed file from ADDBAD3.COM procedure and 
remove the first four lines of the file.  Then exit the editor with EXIT 
and select the READ option from the ADDBAD menu.  If successful you will 
then select the FAST option 2 times since there are now two versions of 
this file, the malformed one and the one you just edited by removing 4 
lines.

  - attempt to reformat the heading lines if there is an error you can spot.
Leave the editor with EXIT and select READ from the ADDBAD menu.  If 
successful then select the FAST option 2 times.

  - examine carefully the "TO" line to see if the topic specified is valid
or perhaps surrounded by extra characters.  The topic should be followed
by the @ sign.  Sometimes removing any double quote marks encountered on
this line helps.

  - if all else fails you can EXIT the editor selecting another file to 
save the message in.  Then invoke the bulletin board utility in the normal 
way and add the file you just saved. This has always been successful for 
me.  However this is quite time consuming and should only be done with 
messages that are of general interest or may be quite important.  This of
course destroys the possibility of users replying to that message directly
to the poster, as the manager is now listed as the poster of the message.}


[inherit('sys$library:starlet')]  {needed to call system routines}
program bb_arpa(bbfile,ifile,input,output);

const
  display_height=17;
  display_width=80;
  header_lines=4;
  null_date=chr(0)+chr(0)+chr(0)+chr(0)+chr(0)+chr(0)+chr(0)+chr(0);
  blocksize=512*3;			{3 block records in main data file}
  date_length=8;
  topic_length=16;
  username_length=48;
  subject_length=30;
  data_length=blocksize-date_length-topic_length-
              username_length-subject_length-3;


type
  string = varying [data_length] of char;
  timetype = packed array [1..date_length] of char;
  nametype = packed array [1..username_length] of char;

  bbrec = record
            date : timetype;		
            topic : packed array [1..topic_length] of char;{topic board name}
            poster : nametype;			{person who sent message}
            subject : packed array [1..subject_length] of char;{subject}
            data : varying [data_length] of char;{the message}
            continuation : boolean;		{if message is long}
	    date_posted : timetype;	
          end;

  vms_array = array[1..header_lines] of string;
  

var
  vms_header : bbrec;		{data form for the vms mail header}
  current_record : bbrec;
  bbfile : file of bbrec;
  ifile : text;

  status_code : integer;  {the code returned from a status check}
  i : integer;
  j : integer;

  board : string;  { the name of the board }
  file_location : string;
  date_line : string;
  line : string;
  subj_line :string; { the subject string from vms mail}
  posted_topic : packed array [1..topic_length] of char;
  arpa_date : timetype;
  vms_header_buff : vms_array;	{the vms header data}

  chars : set of char:=['A'..'Z'];
  linear_white_space : set of char:=[chr(9),chr(32)];
  nums : set of char:=['0'..'9'];

  mailer : boolean; 	      {this is a flag for mail from mailer}
  userservice : boolean;      {this is a flag for userservices}



function uc(ch:string):string;		

{Convert a string to upper case.}

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;  

{An inversion routine to unscramble the dates as used by VMS.}

var                                       
  temp:timetype;

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



procedure trim;   

{Removes white spaces from each end of the line.}

begin
  i:=0;
  repeat
    i:=i+1;
  until (not (line[i] in linear_white_space)) or (i=length(line));

  j:=length(line)+1;
  repeat  
    j:=j-1;
  until (not (line[j] in linear_white_space)) or (j=i);

  if (not (line[i] in linear_white_space)) then
    line:=substr(line,i,j-i+1)
  else
    line:='';
end;



procedure set_date; 

{Format the input date to be used by VMS.}

var
  day : varying [2] of char;
  month : varying [3] of char;
  time : varying [8] of char;
  year : varying [4] of char;

begin
  day:='';
  month:='';
  time:='';
  year:='';
  line:=uc(line);
  for i:=1 to length(line) do
    if (line[i] in nums) and (length(day)=0) then
      begin
        j:=i-1;
        repeat
          j:=j+1;
          if line[j] in nums then day:=day+line[j];
        until (length(day)=2) or (not (line[j] in nums)) or
              (j=length(line));
      end;

  if (length(day)<>0) and (j+1<length(line)-1) then
    for i:=j+1 to (length(line)-2) do
      begin
        if (line[i] in chars) and (length(month)=0) then
          begin
            j:=i+3;
            month:=substr(line,i,3);
          end;
      end;

  if (length(month)<>0) and (j<length(line)) then
    for i:=j to length(line) do
      if (line[i] in nums) and (length(year)=0) then
        begin
          j:=i-1;
          repeat
            j:=j+1;
            if line[j] in nums then year:=year+line[j];
          until (length(year)=4) or (not (line[j] in nums)) or
                (j=length(line));
          if length(year)=2 then year:='19'+year;
        end;

  if (length(year)<>0) and (j+1<length(line)) then
    for i:=j+1 to length(line) do
      if (line[i] in nums) and (length(time)=0) then
        begin
          j:=i-1;
          repeat
            j:=j+1;
            if (line[j] in nums) or (line[j]=':') then
              time:=time+line[j];
          until (length(time)=8) or
                (not ((line[j] in nums) or (line[j]=':'))) or
                (j=length(line));
          if (index(time,':')=0) and (length(time)>3) then
            begin
              time:=substr(time,1,2)+':'+substr(time,3,length(time)-2);
              if length(time)>6 then
                time:=substr(time,1,5)+':'+substr(time,6,length(time)-5);
            end;
        end;

  line:=day+'-'+month+'-'+year+' '+time;
  if odd($bintim(timbuf:=line,timadr:=arpa_date)) then
    current_record.date:=invert(arpa_date);
end;



procedure set_user;  

{Parse address of sender.}

var
  b_start : integer;
  b_stop : integer;
  p_start : integer;
  p_stop : integer;
  temp : string;

begin
  b_start:=index(line,'<');
  i:=length(line)+1;

  repeat
    i:=i-1;
  until (line[i]='>') or (i=1);

  if line[i]='>' then b_stop:=i;
  if (b_start>0) and (b_stop>0) then
    line:=substr(line,b_start+1,b_stop-b_start-1);

  p_start:=index(line,'(');
  i:=length(line)+1;

  repeat
    i:=i-1;
  until (line[i]=')') or (i=1);

  if line[i]=')' then p_stop:=i;

  if (p_start>0) and (p_stop>0) then
    begin
      temp:='';
      if p_start>1 then temp:=substr(line,1,p_start-1);
      if p_stop<length(line) then
        temp:=temp+substr(line,p_stop+1,length(line)-p_stop);
      line:=temp;
    end;

  if length(line)>username_length then
    line:=substr(line,1,username_length);
  trim;
  current_record.poster:=line;
end;



procedure set_subject;   

{Parse subject of message.}

begin
  if length(line)>subject_length then
    begin
      line:=substr(line,1,subject_length);
      trim;
    end;
  current_record.subject:=line;
end;



procedure set_topic;   

{Parse topic board for message.}

var
  temp : packed array [1..16] of char;
  topic : string;

begin
  line:=uc(line);

  repeat
    i:=index(line,'@');

    if i=0 then
      topic:=line
    else
      topic:=substr(line,1,i-1);

    if (i=0) or (i=length(line)) then
      line:=''
    else
      line:=substr(line,i+1,length(line)-i);

    if length(topic)<>0 then
      begin
        i:=length(topic);
        if i>topic_length then i:=topic_length;

        repeat
          temp:=substr(topic,1,i);
          i:=i-1;
          findk(bbfile,0,null_date+temp,eql,error:=continue);
        until (not ufb(bbfile)) or (i=0);

        if ufb(bbfile) and (length(topic)>1) then
          begin
            i:=1;
            if length(topic)>topic_length+1 then i:=length(topic)-topic_length;

            repeat
              i:=i+1;
              temp:=substr(topic,i,length(topic)-i+1);
              findk(bbfile,0,null_date+temp,eql,error:=continue);
            until (not ufb(bbfile)) or (i=length(topic));

          end;
      end;
  until (not ufb(bbfile)) or (length(line)=0);

  if not ufb(bbfile) then current_record.topic:=temp;
  posted_topic := current_record.topic;
end;



procedure arpa_header;			

{Sets up header fields in record.}

var
  file_line : string;
  found : boolean;
  mess_word : varying [80] of char;
  pos : integer;

begin					{arpa_header}
  current_record.date:='';
  current_record.topic:='';
  current_record.poster:='';
  current_record.subject:='';
  found:=false;

  repeat
    readln(ifile,file_line);
    if (length(file_line) > 0) then
    begin
    pos:=index(file_line,':');

    if (pos>0) or ((file_line[1]=' ') and found) then
      begin
        if file_line[1]<>' ' then
          mess_word:=uc(substr(file_line,1,pos-1))
        else
          pos:=0;
        line:=substr(file_line,pos+1,length(file_line)-pos);
        found:=true;
        if length(line)<>0 then
          begin
            trim;
            if (mess_word='FROM') and (current_record.poster='') then set_user;
            if (mess_word='SUBJECT') and (current_record.subject='') then
              set_subject;
            if current_record.date='' then
              begin
                if length(mess_word)>4 then
                  mess_word:=substr(mess_word,length(mess_word)-3,4);
                if mess_word='DATE' then set_date;
              end;
            if current_record.topic='' then
              begin
                if length(mess_word)>2 then
                  mess_word:=substr(mess_word,length(mess_word)-1,2);
                if (mess_word='TO') or (mess_word='CC') then set_topic;
              end;
          end;
	end;
      end;
  until (found and (length(file_line)=0)) or eof(ifile);

  if (current_record.date='') then
    if odd($bintim(timbuf:='-',timadr:=arpa_date)) then
      current_record.date:=invert(arpa_date);

  if (current_record.date='') or (current_record.topic='') then   
    begin
      writeln('Date or topic null in procedure arpa_header');
      $exit(code:=44);
    end;
end;



procedure from_who;  

{Was the message from tcp-ip, VMS or local?}

var
   vms_start : integer;		
   vms_stop  : integer;
   date_start : integer;
   date_stop : integer;
   sender : string;

begin
  mailer := true;
  vms_start := index(line,'::');

  if vms_start>0 then
    begin
      vms_start := vms_start + 2;  
      vms_stop := index(line,' ');
      sender := substr(line,vms_start,vms_stop);
      date_start := index(line,' ');
      if date_start = 0 then date_start := 1;
      date_stop := length(line)-date_start+1;
      date_line := substr(line,date_start,date_stop);
      line := date_line;
      trim;
      date_line := line;
      uc(sender);
      line := sender;
      trim;
      sender := line;
      if sender = 'MAILER' then
        mailer:=true
      else
        begin
	  mailer:=false;
          current_record.poster := sender;
	end;
      line := date_line;
      set_date;
    end
end;


procedure to_who;   

{Who was message sent to?}

var
   vms_start : integer;
   vms_stop  : integer;
   receiver : string;

begin
  vms_start := index(line,'USERSERVICES');

  if vms_start>0 then
    begin
      vms_start := vms_start;
      vms_stop := vms_start + 12;
    end
  else
    begin
      vms_start := 1;
      vms_stop := index(line,'@');
    end;

  if vms_stop < 1 then vms_stop := length(line) + 1;
    if vms_stop>0 then
      begin
        vms_stop := vms_stop - vms_start;
        receiver := substr(line,vms_start,vms_stop);
        uc(receiver);
        line := receiver;
        trim;
        receiver := line;
        if receiver = 'USERSERVICES' then
            userservice:=true
	else
	    userservice:=false;
      end
end;



procedure get_subject;   

{Get the subject from the vms header.}

var 
    subj_start,subj_stop,board_start,board_stop : integer;
    temp_line : string;

begin
  temp_line := line;

  if (mailer and userservice) then
    set_user;

  line := temp_line;

  {Find the subject.}
  subj_start := index(line,']');
  if subj_start > 0 then 
    begin
      subj_start := subj_start + 2;
      subj_stop := (length(line) - subj_start) + 1;
      if (subj_stop > 0) then 
        line := substr(line,subj_start,subj_stop);
      subj_start := 1;
      subj_stop := index(line,'@') - 1;
      if Subj_stop < 1 then 
        begin
	  subj_stop := index(line,' ') - 1;
	  if Subj_stop < 1 then subj_stop := length(line);
	end;    
    end
  else
    begin
      subj_start := 1;
      subj_stop := index(line,'@') - 1;
      if subj_stop < 1 then 
	begin
	  subj_stop := index(line,' ') - 1;
	  if subj_stop < 1 then subj_stop := length(line);
        end;
     end;
  subj_line := substr(line,subj_start,subj_stop);

  {Find topic board.}
  board_start := index(line,'@') + 1;
  if (board_start > 1) then
    begin
      board_stop := length(line) - board_start + 1;
      board := substr(line,board_start,board_stop);
    end
  else
    board := '';
  line := board;
  set_topic;
  line := subj_line;
  set_subject;
end;	



procedure process_vms_header;   

{Parse the VMS mail header.}

var 
  count : integer ; {just a counter}
  buff_line : string;
  found : boolean;
  mess_word : varying [80] of char;
  pos : integer;

begin
  current_record.date:='';
  current_record.topic:='';
  current_record.poster:='';
  current_record.subject:='';

  for count := 1 to header_lines do
    begin
      vms_header_buff[count] := '';
      readln(ifile,vms_header_buff[count]);
    end;

  count := 1;
  found:=false;

  repeat
    buff_line := vms_header_buff[count];
    pos:=index(buff_line,':');
    if (pos>0) or ((length(buff_line) > 0) and found) then
      begin
        if buff_line[1]<>' ' then
          mess_word:=uc(substr(buff_line,1,pos-1))
        else
          pos:=0;
        line:=substr(buff_line,pos+1,length(buff_line)-pos);
        found:=true;

        if length(line)<>0 then
          begin
            trim;
            if (mess_word='FROM') then from_who;
            if (mess_word='TO') then to_who;
            if (mess_word='SUBJ') then get_subject;
          end;

      end;
      count := count + 1;
    until (count > 4) or (found and (length(buff_line)=0)) or eof(ifile);

    if (current_record.date='') then
      if odd($bintim(timbuf:='-',timadr:=arpa_date)) then
        current_record.date:=invert(arpa_date);

    if (current_record.date='') or (current_record.topic='') then 
      begin
        write('Null date or topic in process_vms_header.');
        writeln('  Trying tcp-ip');
        userservice := false;
      end;
end;
  

procedure put_arpa;		

{Copy ARPA file into database.}

{NOTE: there is a poblem that is generated intermittently from this
procedure.  The error is a substring selection error.  As near as
I can guess this is caused by messages created in MAIL or EDT
and a carriage return is not the last character typed in the
message.  I have not been able to generate a fix for this problem.
The error messages go into the log file and the file causing the
problem stays around as BB$BAD_MAIL.TXT if the file has other problems
or goes into the data base if the header is ok.  This substring
selection error seems to generate no problems in the data base itself.}

var 
  count : integer;
  filename : string;

begin				
  write('File to add: ');
  readln(filename);
  open(ifile,filename,history:=readonly,error:=continue); 

  if status(ifile)<>0 then   
    begin
      writeln('No ',filename,' input file found in put_arpa.');
      $exit(code:=44); {These 'dummy' codes are used by BB$MAIL.COM for}
    end;               {looping on the status code returned, odd or even}

  reset(ifile);
  mailer := true;
  userservice := false;
  process_vms_header;

  if (mailer and not userservice) then 
    arpa_header;

  {The old version of the program stored the messages as the date the
   sender posted the message as the first key field.  This worked fine
   unless several days passed before the message was delivered to us.
   This delay in arrival often fragmented the data base file and made
   loading of the messages very slow.  In order to correct this A.M.P.
   chose to swap date fields at this point.  Now messages will be stored
   in the order that they are received.  Now all messages received since the
   last date of access will be stored together and will appear together
   in the message list.}

  current_record.date_posted := current_record.date;
  $gettim(arpa_date);   {set the date the message was posted to the bb}
  current_record.date:=invert(arpa_date);

  with current_record do
    begin
      findk(bbfile,0,date+topic,eql,error:=continue);
      if not ufb(bbfile) then 	
	begin
	  writeln('Record invalid in put_arpa. No matching date+topic: ',
                      topic);
	  $exit(code:=44);
	end;
      count:=0;

      repeat
        if count>display_height then
          begin
            data:=line+chr(13)+chr(10);
            count:=(length(line) div (display_width+1))+1;
          end
        else
          begin
            data:='';
            count:=0;
          end;

        repeat
          readln(ifile,line);

          if status(ifile)>0 then 
  	    begin
	      writeln('Error in reading ',filename,' input file in put_arpa.');
	      $exit(code:=44);
	    end;

          count:=count+(length(line) div (display_width+1))+1;
          if count<=display_height then data:=data+line+chr(13)+chr(10);
        until (count>=display_height) or eof(ifile);

        if (topic <> '') then
          write(bbfile,current_record,ERROR:=continue)
        else
          begin
            writeln('Topic is null string in put_arpa. Message not added.');
            $exit(code:=44);
          end;

        {Finds messages that are going to be doubled in data base.}
        status_code := status(bbfile);   { finds if error happen }
        if ((status_code <> 0) and (topic <> ''))  then
          begin
            writeln('Writing double in put_arpa to ',posted_topic,' ',
                     current_record.subject);
            writeln('Double error def vax pascal user guide appendix B ',
                     status_code);
            writeln('Deleted file that was a double message');
            $exit(code:=43);  {odd value - file will be deleted by JCL}
          end
        else
          continuation:=true;
      until eof(ifile);
    end;

  close(ifile,error:=continue);
  if ((status_code = 0) and (current_record.topic <> '')) then 
    writeln('Message added from ',filename,' to ',posted_topic,
             '   Subject: ',current_record.subject);
end;



begin   {Main program}
  file_location:='system3:[bb$program.data]bb$bitnet_boards.dat';
  
  open(bbfile,file_location,history:=old,access_method:=keyed,
       organization:=indexed,sharing:=readwrite);

  if status(bbfile)>0 then 
    begin
      writeln('COULD NOT OPEN BBFILE IN MAIN PROGRAM');
      $exit(code:=44);
    end;

  put_arpa;

  close(bbfile,error:=continue)

end.