integer function mail_out_connect (context, function, protocol, 1 node, mail$_loglink, file_rat, file_rfm, mail$gl_flags, 2 attached_file) c MAIL_OUT_CONNECT is called by VMS MAIL to initiate a send operation. implicit none include '($ssdef)' include 'prot_inc.for' integer*4 context,function,mail$_loglink,file_rat integer*4 file_rfm,mail$gl_flags integer*4 attached_file character*(*) protocol character*(*) node c character*(*) attached_file character*12 filename external uopen external ubbsml__filopnerr from_string = ' ' to_string = ' ' subject_string = ' ' num_addresses = 0 c open the userlog and message files filename = 'USERLOG.DAT' open(unit=1,file='ubbs_data:userlog.dat',status='old', 1 organization='indexed',access='keyed',err=1000, 2 recordtype='fixed',recl=50,shared,useropen=uopen) filename = 'MESSAGE.HED' open(unit=2,file='ubbs_data:message.hed',status='old', 1 organization='relative',access='direct',err=1000, 2 recordtype='fixed',recl=48,shared,useropen=uopen) filename = 'MESSAGE.DAT' open(unit=3,file='ubbs_data:message.dat',status='old', 1 organization='relative',access='direct',err=1000, 2 recordtype='fixed',recl=20,shared,useropen=uopen) mail_out_connect = ss$_normal return 1000 call lib$signal(ubbsml__filopnerr, 1 %val(1), filename) c Don't set return code to normal on error return end integer function mail_out_line(context,function,node,line) c MAIL_OUT_LINE is called by VMS MAIL whenever a single line of stuff c must be delivered to the UBBS mail interface. c These currently are the To:, From:, and Subject: lines. implicit none include '($ssdef)' include 'prot_inc.for' integer*4 context,function,node,func2 character*(*) line c The following is because function is passed by value, and FORTRAN c thinks that it is an address. func2 = %loc(function) if(func2.eq.lnk_c_out_to) then to_string = line else if (func2.eq.lnk_c_out_sender) then from_string = line else if(func2.eq.lnk_c_out_subject) then subject_string = line end if mail_out_line = ss$_normal end integer function MAIL_OUT_CHECK(context,function,node,addressee,error) c MAIL_OUT_CHECK is called once with each addressee for the current c message and once again after the message body has been sent. implicit none include 'bbs_inc.for' include 'prot_inc.for' integer context,function,func2,error,jj,istat logical*1 valid character*(*) node,addressee character zmail_to*40,zfirst_name*20,zlast_name*20,yn*1 external ubbsml__usernoexist 1001 format(a) func2 = %loc(function) if(func2.eq.lnk_c_out_ckuser) then if(len(addressee).eq.1.and.ichar(addressee(1:1)).eq.0) then mail_out_check = ss$_normal return end if jj=index(addressee,'/') if(jj.eq.0) jj = len(addressee) + 1 call str$upcase(zmail_to,addressee(1:jj-1)) jj = index(zmail_to,' ') zfirst_name=zmail_to(1:jj-1) zlast_name=zmail_to(jj+1:30) ur.user_key=zlast_name//zfirst_name read(1,key=ur.user_key,iostat=istat)ur unlock(unit=1) if(istat.eq.0) then num_addresses = num_addresses + 1 address(num_addresses) = addressee else call lib$signal(ubbsml__usernoexist,%val(1), addressee) write(*,*) 'Do you wish to make this a general message? [N]' read(*,1001)yn call str$upcase(yn,yn) if(yn.ne.'Y') then mail_out_check = %loc(ubbsml__usernoexist) return end if end if else if(func2.eq.lnk_c_out_cksend) then continue end if mail_out_check = ss$_normal return end integer function MAIL_OUT_FILE(context,function,node, 1 message_rab,error) c MAIL_OUT_FILE is called when the body of the message is ready to be c sent. The message is available as a file and must be read from this c temporary file using RMS. MAIL_OUT_FILE is where most of the actual c work takes place. The following steps are taken: c c (1) The mode of the message file is set to record I/O (MAIL sometimes c leaves the file in block mode). c c (2) Put the message in the UBBS message files for each user. implicit none include '($rabdef)' include '($rmsdef)' include 'prot_inc.for' include 'bbs_inc.for' integer context,function,error,length,num_lines,stat,ii,i,istat integer jj,j logical get_line,busy character line*256,options*30,temp*30 character zfirst_name*20,zlast_name*20,zmail_to*30 character*(*) node integer sys$get external ubbsml__mesreaerr external ubbsml__publmess record/rabdef/ message_rab record/mail_header_structure/ mh c Do some fancy footwork with RMS to insure that the file is open c for sequential access and not block access. MAIL sometimes has c this file open in block mode. The only way to change modes is c to disconnect the RAB, diddle the mode bit and then reconnect it. call sys$disconnect (message_rab) message_rab.rab$l_rop = message_rab.rab$l_rop .and. (.not.rab$m_bio) call sys$connect (message_rab) call sys$rewind (message_rab) get_line = .true. num_lines = 0 do while (get_line) message_rab.rab$l_ubf = %loc(line) message_rab.rab$w_usz = 256 stat = sys$get (message_rab) if(mod(stat,2).eq.1) then length = message_rab.rab$w_rsz num_lines = num_lines + 1 else if (stat .eq. rms$_eof) then get_line = .false. else call lib$signal (ubbsml__mesreaerr, 1, stat) end if end do i = index(from_string,'"') if(i.ne.0) then from_string = from_string(i+1:) i=index(from_string,'"') if(i.ne.0) from_string = from_string(1:i-1) end if do ii = 1,num_addresses 3090 read(2,rec=1)last_header,last_data, 1 first_mnum,last_mnum,busy if(busy) then unlock(unit=2) call lib$wait(1.0) go to 3090 end if last_header=last_header+1 last_mnum=last_mnum+1 write(2,rec=1)last_header,last_data+num_lines, 1 first_mnum,last_mnum,busy call date(mh.mail_date) call time(mh.mail_time) mh.mail_read=.false. mh.mail_deleted=.false. mh.mail_subject=subject_string i = index(address(ii),'/') if (i.eq.0) then i=31 mh.mail_section = 0 mh.mail_private = .true. else options = address(ii)(i+1:)//'///' c extract first option (private [Y/N]) j = index(options,'/') temp = options(1:j) options = options(j+1:) if(temp(1:1).eq.'N') then mh.mail_private = .false. else mh.mail_private = .true. end if end if mh.mail_to=address(ii)(1:i-1) mh.mail_reply_to=0 do i=1,10 mh.mail_replys(i)=0 end do mh.mail_first=last_data+1 mh.mail_last=last_data+num_lines mh.mail_from=from_string mh.mail_messnum=last_mnum call str$upcase(zmail_to,mh.mail_to) jj = index(zmail_to,' ') zfirst_name=zmail_to(1:jj-1) zlast_name=zmail_to(jj+1:30) ur.user_key=zlast_name//zfirst_name read(1,key=ur.user_key,iostat=istat)ur if(istat.eq.0) then mh.mail_person = .true. else mh.mail_person = .false. mh.mail_private = .false. call lib$signal(ubbsml__publmess,%val(1),zmail_to) end if write(2,rec=last_header) mh call sys$rewind (message_rab) get_line = .true. num_lines = 0 do while (get_line) line = ' ' message_rab.rab$l_ubf = %loc(line) message_rab.rab$w_usz = 256 stat = sys$get (message_rab) if(mod(stat,2).eq.1) then length = message_rab.rab$w_rsz num_lines = num_lines + 1 write(3,rec=last_data+num_lines)line(1:80) else if (stat .eq. rms$_eof) then get_line = .false. else call lib$signal (ubbsml__mesreaerr, 1, stat) end if end do read(1,key=ur.user_key,iostat=istat)ur if(istat.eq.0) then ur.num_unread = ur.num_unread + 1 rewrite(1)ur else print*,'error on user log - istat=',istat end if end do mail_out_file = ss$_normal return end integer function MAIL_OUT_DEACCESS(context,function) include '($ssdef)' close(unit=1) close(unit=2) close(unit=3) mail_out_deaccess = ss$_normal return end integer function MAIL_IN_CONNECT include '($ssdef)' mail_in_connect = ss$_normal return end integer function MAIL_IN_LINE include '($ssdef)' mail_in_line = ss$_normal return end integer function MAIL_IN_FILE include '($ssdef)' mail_in_file = ss$_normal return end integer function MAIL_IO_READ include '($ssdef)' mail_io_read = ss$_normal return end integer function MAIL_IO_WRITE include '($ssdef)' mail_io_write = ss$_normal return end integer function uopen(fab,rab,lun) implicit none include '($rabdef)' include '($fabdef)' record /rabdef/ rab record /fabdef/ fab integer sys$open,sys$connect integer lun,status c modify the rab to simplify things rab.rab$l_rop = ibset(rab.rab$l_rop, rab$v_wat) c actually open the file status=sys$open(fab) if(status) status=sys$connect(rab) c return the status uopen=status return end