-+-+-+-+-+-+-+-+ START OF PART 10 -+-+-+-+-+-+-+-+
X; Modified by Ned Freed, 16-Nov-86, to use proper global symbols.
X;
X;---------------------------------------------------------------------------
X; This is invoked by MAIL when it encounters the foreign mail protocol.
X; This module really has nothing protocol-specific to it and can be used
X; to dispatch to any handler.  The handler should supply the following
X; action routines:
X;
X;`09status := MAIL_OUT_CONNECT (context : unsigned;
X;`09`09`09`09    LNK_C_OUT_CONNECT : immediate;
X;`09`09`09`09    protocol, node : string_descriptor;
X;`09`09`09`09    MAIL$_LOGLINK : immediate;
X;`09`09`09`09    file_RAT, file_RFM : immediate;
X;`09`09`09`09    MAIL$GL_FLAGS : immediate;
X;`09`09`09`09    attached_file : descriptor := immediate 0)
X;
X;`09status := MAIL_OUT_LINE    (context : unsigned;
X;`09`09`09`09    `5BLNK_C_OUT_SENDER `7C LNK_C_OUT_TO `7C
X;`09`09`09`09     LNK_C_OUT_SUBJ`5D : immediate;
X;`09`09`09`09    node, sender_name : string_descriptor)
X;
X;`09status := MAIL_OUT_CHECK   (context : unsigned;
X;`09`09`09`09    `5BLNK_C_OUT_CKUSER `7C
X;`09`09`09`09     LNK_C_OUT_CKSEND`5D : immediate;
X;`09`09`09`09    node, addressee : string_descriptor;
X;`09`09`09`09    procedure MAIL$READ_ERROR_TEXT);
X;
X;`09status := MAIL_OUT_FILE    (context : unsigned;
X;`09`09`09`09    LNK_C_OUT_FILE : immediate;
X;`09`09`09`09    node : string_descriptor;
X;`09`09`09`09    rab : $RAB_TYPE;
X;`09`09`09`09    procedure UTIL$REPORT_IO_ERROR);
X;
X;`09status := MAIL_OUT_DEACCESS (context : unsigned;
X;`09`09`09`09     LNK_C_OUT_DEACCESS : immediate);
X;
X;`09status := MAIL_IN_CONNECT (context : unsigned;
X;`09`09`09`09   LNK_C_IN_CONNECT : immediate;
X;`09`09`09`09   input_tran : string_descriptor;
X;`09`09`09`09   file_RAT, file_RFM : immediate;
X;`09`09`09`09   MAIL$GL_FLAGS : immediate;
X;`09`09`09`09   MAIL$Q_PROTOCOL : string_descriptor;
X;`09`09`09`09   pflags : immediate);
X;
X;`09status := MAIL_IN_LINE   (context : unsigned;
X;`09`09`09`09  `5BLNK_C_IN_SENDER `7C LNK_C_IN_CKUSER `7C
X;`09`09`09`09   LNK_C_IN_TO `7C LNK_C_IN_SUBJ`5D : immediate;
X;`09`09`09`09  returned_line : string_descriptor);
X;
X;`09status := MAIL_IN_FILE     (context : unsigned;
X;`09`09`09`09    LNK_C_OUT_FILE : immediate;
X;`09`09`09`09    0 : immediate;
X;`09`09`09`09    rab : $RAB_TYPE;
X;`09`09`09`09    procedure UTIL$REPORT_IO_ERROR);
X;
X;`09status := MAIL_IO_READ  (context : unsigned;
X;`09`09`09`09 LNK_C_IO_READ : immediate;
X;`09`09`09`09 returned_text_line : string_descriptor);
X;
X;`09status := MAIL_IO_WRITE (context : unsigned;
X;`09`09`09`09 LNK_C_IO_WRITE : immediate;
X;`09`09`09`09 text_line : string_descriptor);
X;
X;---------------------------------------------------------------------------
X;
X; Define major and minor protocol identifiers.  MAIL requires that these
X; be 1.  The shareable image MUST be linked with the options file MAILSHR.OP
VT
X; that promotes these symbols to UNIVERSAL symbols so they will end up
X; in the shareable image's symbol table.
X;
X`09`09MAIL$C_PROT_MAJOR == 1
X`09`09MAIL$C_PROT_MINOR == 1
X;
X; Constants for dispatcher, taken from MAIL.SDL listing
X;
X`09LNK_C_FIRST = 0
X`09LNK_C_OUT_CONNECT  == 0
X`09LNK_C_OUT_SENDER   == 1
X`09LNK_C_OUT_CKUSER   == 2
X`09LNK_C_OUT_TO`09   == 3
X`09LNK_C_OUT_SUBJ`09   == 4
X`09LNK_C_OUT_FILE`09   == 5
X`09LNK_C_OUT_CKSEND   == 6
X`09LNK_C_OUT_DEACCESS == 7
X
X`09LNK_C_IN_CONNECT   == 8
X`09LNK_C_IN_SENDER    == 9
X`09LNK_C_IN_CKUSER    == 10
X`09LNK_C_IN_TO`09   == 11
X`09LNK_C_IN_SUBJ`09   == 12
X`09LNK_C_IN_FILE`09   == 13
X
X`09LNK_C_IO_READ`09   == 14
X`09LNK_C_IO_WRITE`09   == 15
X`09LNK_C_LAST = 15
X;
X; Here's the main routine that is called by MAIL.  Note that we don't really
X; do any work here, just dispatch the call to the appropriate handler.  The
X; reason I do it this way is that I am not interested in writing the handler
Vs
X; in MACRO, and I cannot easily deal with different numbers of arguments in
X; the same procedure in other languages.
X;
X
X;
X; General argument offset to the function code:
X;
X`09LNK_FUNCTION = 8
X;
X; Shareable image transfer vectors
X;
X`09.Transfer`09MAIL$PROTOCOL
X`09.Mask`09`09MAIL$PROTOCOL
X`09jmp`09L`5EMAIL$PROTOCOL + 2
X
X`09.Entry`09MAIL$PROTOCOL, `5EM<r2,r3>
X
X`09caseb`09LNK_FUNCTION(ap), #LNK_C_FIRST, -`09; Dispatch to handler
X`09`09#<LNK_C_LAST - LNK_C_FIRST>
X
X10$:`09  .word`09Dispatch_out_connect - 10$`09`09; LNK_C_OUT_CONNECT
X`09  .word`09Dispatch_out_line - 10$`09`09`09; LNK_C_OUT_SENDER
X`09  .word`09Dispatch_out_check - 10$`09`09; LNK_C_OUT_CKUSER
X`09  .word`09Dispatch_out_line - 10$`09`09`09; LNK_C_OUT_TO
X`09  .word`09Dispatch_out_line - 10$`09`09`09; LNK_C_OUT_SUBJ
X`09  .word`09Dispatch_out_file - 10$`09`09`09; LNK_C_OUT_FILE
X`09  .word`09Dispatch_out_check - 10$`09`09; LNK_C_OUT_CKSEND
X`09  .word`09Dispatch_out_deaccess - 10$`09`09; LNK_C_OUT_DEACCESS
X
X`09  .word`09Dispatch_in_connect - 10$`09`09; LNK_C_IN_CONNECT
X`09  .word`09Dispatch_in_line - 10$`09`09`09; LNK_C_IN_SENDER
X`09  .word`09Dispatch_in_line - 10$`09`09`09; LNK_C_IN_CKUSER
X`09  .word`09Dispatch_in_line - 10$`09`09`09; LNK_C_IN_TO
X`09  .word`09Dispatch_in_line - 10$`09`09`09; LNK_C_IN_SUBJ
X`09  .word`09Dispatch_in_file - 10$`09`09`09; LNK_C_IN_FILE
X
X`09  .word`09Dispatch_IO_read - 10$`09`09`09; LNK_C_IO_READ
X`09  .word`09Dispatch_IO_write - 10$`09`09`09; LNK_C_IO_WRITE
X
Xunknown:
X`09pushl`09LNK_FUNCTION(ap)`09; FAO parameter in the function code
X`09pushl`09#1
X`09pushl`09#ubbsml__UNKFUNC`09; Signal unknown function code
X`09calls`09#3, G`5ELIB$SIGNAL`09; if we fall through dispatcher.
X`09movl`09#ubbsml__UNKFUNC, r0
X`09ret
X;
X; The dispatchers
X;
XDispatch_out_connect:
X`09callg`09(ap), MAIL_OUT_CONNECT
X`09ret
X
XDispatch_out_line:
X`09callg`09(ap), MAIL_OUT_LINE
X`09ret
X
XDispatch_out_check:
X`09callg`09(ap), MAIL_OUT_CHECK
X`09ret
X
XDispatch_out_file:
X`09callg`09(ap), MAIL_OUT_FILE
X`09ret
X
XDispatch_out_deaccess:
X`09callg`09(ap), MAIL_OUT_DEACCESS
X`09ret
X
XDispatch_in_connect:
X`09callg`09(ap), MAIL_IN_CONNECT
X`09ret
X
XDispatch_in_line:
X`09callg`09(ap), MAIL_IN_LINE
X`09ret
X
XDispatch_in_file:
X`09callg`09(ap), MAIL_IN_FILE
X`09ret
X
XDispatch_IO_read:
X`09callg`09(ap), MAIL_IO_READ
X`09ret
X
XDispatch_IO_write:
X`09callg`09(ap), MAIL_IO_WRITE
X`09ret
X
X`09.end
$ CALL UNPACK [.MAIL_PROTOCOL]MAILSHR.MAR;3 1813544556
$ create 'f'
Xuniversal=MAIL$C_PROT_MAJOR, MAIL$C_PROT_MINOR
$ CALL UNPACK [.MAIL_PROTOCOL]MAILSHR.OPT;2 993680312
$ create 'f'
X`09parameter LNK_C_OUT_CONNECT  = 0 !(* MAIL protocol link actions.
V           *)
X`09parameter LNK_C_OUT_SENDER   = 1 !(* These are defined in MAILSHR.MAR
V      *)
X`09parameter LNK_C_OUT_CKUSER   = 2 !(* but because we cannot have external
V   *)
X`09parameter LNK_C_OUT_TO       = 3 !(* constants in Pascal, they are
V         *)
X`09parameter LNK_C_OUT_SUBJECT  = 4 !(* redefined here.
V                       *)
X`09parameter LNK_C_OUT_FILE     = 5
X`09parameter LNK_C_OUT_CKSEND   = 6
X`09parameter LNK_C_OUT_DEACCESS = 7
X`09parameter LNK_C_IN_CONNECT = 8
X`09parameter LNK_C_IN_SENDER  = 9
X`09parameter LNK_C_IN_CKUSER  = 10
X`09parameter LNK_C_IN_TO      = 11
X`09parameter LNK_C_IN_SUBJ    = 12
X`09parameter LNK_C_IN_FILE    = 13
X`09parameter LNK_C_IO_READ  = 14
X`09parameter LNK_C_IO_WRITE = 15
X
X`09character*80 from_string,to_string,subject_string,address(40)
X`09common /mailchars/ from_string,to_string,subject_string,address
X`09integer*4    num_addresses
X`09common/mailints/ num_addresses
$ CALL UNPACK [.MAIL_PROTOCOL]PROT_INC.FOR;7 320155909
$ create 'f'
X`09integer function mail_out_connect (context, function, protocol,
X`091   node, mail$_loglink, file_rat, file_rfm, mail$gl_flags,
X`092   attached_file)
X
Xc`09MAIL_OUT_CONNECT is called by VMS MAIL to initiate a send operation.
X
X`09implicit none
X`09include '($ssdef)'
X`09include 'prot_inc.for'
X
X`09integer*4 context,function,mail$_loglink,file_rat
X`09integer*4 file_rfm,mail$gl_flags
X`09integer*4 attached_file
X`09character*(*) protocol
X`09character*(*) node
Xc`09character*(*) attached_file
X`09character*12 filename
X`09external uopen
X`09external ubbsml__filopnerr
X
X
X`09from_string = ' '
X`09to_string = ' '
X`09subject_string = ' '
X`09num_addresses = 0
X
Xc`09open the userlog and message files
X`09filename = 'USERLOG.DAT'
X`09open(unit=1,file='ubbs_data:userlog.dat',status='old',`09
X`091   organization='indexed',access='keyed',err=1000,
X`092   recordtype='fixed',recl=50,shared,useropen=uopen)
X`09filename = 'MESSAGE.HED'
X`09open(unit=2,file='ubbs_data:message.hed',status='old',`09
X`091   organization='relative',access='direct',err=1000,
X`092   recordtype='fixed',recl=48,shared,useropen=uopen)
X`09filename = 'MESSAGE.DAT'
X`09open(unit=3,file='ubbs_data:message.dat',status='old',`09
X`091   organization='relative',access='direct',err=1000,
X`092   recordtype='fixed',recl=20,shared,useropen=uopen)
X
X`09mail_out_connect = ss$_normal
X`09return
X
X 1000`09call lib$signal(ubbsml__filopnerr,
X`091   %val(1), filename)
X
Xc`09Don't set return code to normal on error
X`09return
X`09end
X`0C
X`09integer function mail_out_line(context,function,node,line)
X
Xc`09MAIL_OUT_LINE is called by VMS MAIL whenever a single line of stuff
Xc`09must be delivered to the UBBS mail interface.
Xc`09These currently are the To:, From:, and Subject: lines.
X`09implicit none
X`09include '($ssdef)'
X`09include 'prot_inc.for'
X`09integer*4 context,function,node,func2
X`09character*(*) line
X
Xc`09The following is because function is passed by value, and FORTRAN
Xc`09thinks that it is an address.
X
X`09func2 = %loc(function)
X
X`09if(func2.eq.lnk_c_out_to) then
X`09    to_string = line
X`09else if (func2.eq.lnk_c_out_sender) then
X`09    from_string = line
X`09else if(func2.eq.lnk_c_out_subject) then
X`09    subject_string = line
X`09end if
X
X`09mail_out_line = ss$_normal
X`09end
X`0C
X`09integer function MAIL_OUT_CHECK(context,function,node,addressee,error)
Xc`09MAIL_OUT_CHECK is called once with each addressee for the current
Xc`09message and once again after the message body has been sent.
X
X`09implicit none
X`09include 'bbs_inc.for'
X`09include 'prot_inc.for'
X
X`09integer context,function,func2,error,jj,istat
X`09logical*1 valid
X`09character*(*) node,addressee
X`09character zmail_to*40,zfirst_name*20,zlast_name*20,yn*1
X`09external ubbsml__usernoexist
X
X 1001`09format(a)
X
X`09func2 = %loc(function)
X
X`09if(func2.eq.lnk_c_out_ckuser) then
X`09    if(len(addressee).eq.1.and.ichar(addressee(1:1)).eq.0) then
X`09`09mail_out_check = ss$_normal
X`09`09return
X`09`09end if
X`09    jj=index(addressee,'/')
X`09    if(jj.eq.0) jj = len(addressee) + 1
X`09    call str$upcase(zmail_to,addressee(1:jj-1))
X`09    jj = index(zmail_to,' ')
X`09    zfirst_name=zmail_to(1:jj-1)`09
X`09    zlast_name=zmail_to(jj+1:30)
X`09    ur.user_key=zlast_name//zfirst_name
X`09    read(1,key=ur.user_key,iostat=istat)ur
X`09    unlock(unit=1)
X`09    if(istat.eq.0) then
X`09`09num_addresses = num_addresses + 1
X`09`09address(num_addresses) = addressee
X`09    else
X`09`09call lib$signal(ubbsml__usernoexist,%val(1), addressee)
X`09`09write(*,*) 'Do you wish to make this a general message? `5BN`5D'
X`09`09read(*,1001)yn
X`09`09call str$upcase(yn,yn)
X`09`09if(yn.ne.'Y') then
X`09`09    mail_out_check = %loc(ubbsml__usernoexist)
X`09`09    return
X`09`09    end if
X`09    end if
X`09else if(func2.eq.lnk_c_out_cksend) then
X`09    continue
X`09end if
X`09mail_out_check = ss$_normal
X`09return
X`09end
X`0C
X`09integer function MAIL_OUT_FILE(context,function,node,
X`091    message_rab,error)
Xc`09MAIL_OUT_FILE is called when the body of the message is ready to be
Xc`09sent. The message is available as a file and must be read from this
Xc`09temporary file using RMS. MAIL_OUT_FILE is where most of the actual
Xc`09work takes place. The following steps are taken:
Xc
Xc   (1) The mode of the message file is set to record I/O (MAIL sometimes
Xc       leaves the file in block mode).
Xc
Xc   (2) Put the message in the UBBS message files for each user.
X
X`09implicit none
X`09include '($rabdef)'
X`09include '($rmsdef)'
X`09include 'prot_inc.for'
X`09include 'bbs_inc.for'
X`09integer context,function,error,length,num_lines,stat,ii,i,istat
X`09integer jj,j
X`09logical get_line,busy
X`09character line*256,options*30,temp*30
X`09character zfirst_name*20,zlast_name*20,zmail_to*30
X`09character*(*) node
X`09integer sys$get
X`09external ubbsml__mesreaerr
X`09external ubbsml__publmess
X
X`09record/rabdef/ message_rab
X`09record/mail_header_structure/ mh
X
X
Xc`09Do some fancy footwork with RMS to insure that the file is open
Xc`09for sequential access and not block access. MAIL sometimes has
Xc`09this file open in block mode. The only way to change modes is
Xc`09to disconnect the RAB, diddle the mode bit and then reconnect it.
X
X`09call sys$disconnect (message_rab)
X`09message_rab.rab$l_rop = message_rab.rab$l_rop .and. (.not.rab$m_bio)
X`09call sys$connect (message_rab)
X
X`09call sys$rewind (message_rab)
X`09
X`09get_line = .true.
X`09num_lines = 0
X`09do while (get_line)
X`09    message_rab.rab$l_ubf = %loc(line)
X`09    message_rab.rab$w_usz = 256
X`09    stat = sys$get (message_rab)
X`09    if(mod(stat,2).eq.1) then
X`09`09length = message_rab.rab$w_rsz
X`09`09num_lines = num_lines + 1
X`09    else if (stat .eq. rms$_eof) then
X`09`09get_line = .false.
X`09    else
X`09`09call lib$signal (ubbsml__mesreaerr, 1, stat)
X`09    end if
X`09    end do
X
X`09i = index(from_string,'"')
X`09if(i.ne.0) then
X`09    from_string = from_string(i+1:)
X`09    i=index(from_string,'"')
X`09    if(i.ne.0) from_string = from_string(1:i-1)
X`09    end if
X
X`09do ii = 1,num_addresses
X
X 3090`09read(2,rec=1)last_header,last_data,
X`091   first_mnum,last_mnum,busy
X`09if(busy) then
X`09    unlock(unit=2)
X`09     call lib$wait(1.0)
X`09    go to 3090
X`09    end if
X
X`09last_header=last_header+1
X`09last_mnum=last_mnum+1
X`09write(2,rec=1)last_header,last_data+num_lines,
X`091   first_mnum,last_mnum,busy
X`09call date(mh.mail_date)
X`09call time(mh.mail_time)
X
X`09mh.mail_read=.false.
X`09mh.mail_deleted=.false.
X`09mh.mail_subject=subject_string
X`09i = index(address(ii),'/')
X`09if (i.eq.0) then
X`09    i=31
X`09    mh.mail_section = 0
X`09    mh.mail_private = .true.
X`09else
X`09    options = address(ii)(i+1:)//'///'
Xc`09    extract first option (private `5BY/N`5D)
X`09    j = index(options,'/')
X`09    temp = options(1:j)
X`09    options = options(j+1:)
X`09    if(temp(1:1).eq.'N') then
X`09`09mh.mail_private = .false.
X`09    else
X`09`09mh.mail_private = .true.
X`09    end if
X`09end if
X`09mh.mail_to=address(ii)(1:i-1)
X`09mh.mail_reply_to=0
X`09do i=1,10
X`09    mh.mail_replys(i)=0
X`09    end do
X`09mh.mail_first=last_data+1
X`09mh.mail_last=last_data+num_lines
X`09mh.mail_from=from_string
X`09mh.mail_messnum=last_mnum
X`09call str$upcase(zmail_to,mh.mail_to)
X`09jj = index(zmail_to,' ')
X`09zfirst_name=zmail_to(1:jj-1)`09
X`09zlast_name=zmail_to(jj+1:30)
X`09ur.user_key=zlast_name//zfirst_name
X`09read(1,key=ur.user_key,iostat=istat)ur
X`09if(istat.eq.0) then
X`09    mh.mail_person = .true.
X`09else
X`09    mh.mail_person = .false.
X`09    mh.mail_private = .false.
X`09    call lib$signal(ubbsml__publmess,%val(1),zmail_to)
X
X`09end if
X`09write(2,rec=last_header) mh
X`09call sys$rewind (message_rab)
X`09get_line = .true.
X`09num_lines = 0
X`09do while (get_line)
X`09    line = ' '
X`09    message_rab.rab$l_ubf = %loc(line)
X`09    message_rab.rab$w_usz = 256
X`09    stat = sys$get (message_rab)
X`09    if(mod(stat,2).eq.1) then
X`09`09length = message_rab.rab$w_rsz
X`09`09num_lines = num_lines + 1
X`09`09write(3,rec=last_data+num_lines)line(1:80)
X`09    else if (stat .eq. rms$_eof) then
X`09`09get_line = .false.
X`09    else
X`09`09call lib$signal (ubbsml__mesreaerr, 1, stat)
X`09    end if
X`09    end do
X`09    read(1,key=ur.user_key,iostat=istat)ur
X`09    if(istat.eq.0) then
X`09`09ur.num_unread = ur.num_unread + 1
X`09`09rewrite(1)ur
X`09    else
X`09`09print*,'error on user log - istat=',istat
X`09    end if
X`09    end do
X`09mail_out_file = ss$_normal
X`09return
X`09end
X`0C
X`09integer function MAIL_OUT_DEACCESS(context,function)
X`09include '($ssdef)'
X`09close(unit=1)
X`09close(unit=2)
X`09close(unit=3)
X`09mail_out_deaccess = ss$_normal
X`09return
X`09end
X`0C
X`09integer function MAIL_IN_CONNECT
X`09include '($ssdef)'
X`09mail_in_connect = ss$_normal
X`09return
X`09end
X`09integer function MAIL_IN_LINE
X`09include '($ssdef)'
X`09mail_in_line = ss$_normal
X`09return
X`09end
X`09integer function MAIL_IN_FILE
X`09include '($ssdef)'
X`09mail_in_file = ss$_normal
X`09return
X`09end
X`09integer function MAIL_IO_READ
X`09include '($ssdef)'
X`09mail_io_read = ss$_normal
X`09return
X`09end
X`09integer function MAIL_IO_WRITE
X`09include '($ssdef)'
X`09mail_io_write = ss$_normal
X`09return
X`09end
X`0C
X`09integer function uopen(fab,rab,lun)
X`09implicit none
X
X`09include '($rabdef)'
X`09include '($fabdef)'
X
X`09record /rabdef/ rab
X`09record /fabdef/ fab
X`09integer sys$open,sys$connect
X
X`09integer lun,status
X`09
Xc`09modify the rab to simplify things
X`09rab.rab$l_rop = ibset(rab.rab$l_rop, rab$v_wat)
X
Xc`09actually open the file
X`09status=sys$open(fab)
X`09if(status) status=sys$connect(rab)
Xc`09return the status
X`09uopen=status
X`09return
X`09end
$ CALL UNPACK [.MAIL_PROTOCOL]UBBS_MAILSHR.FOR;6 1210369869
$ create 'f'
X`09  .Title`09UBBSMAIL error messages
X
X! Written by Dale Miller 17-Jan-1989
X
X`09  .Facility`09UBBSML,667/prefix=UBBSML__
X`09  .Ident`09'UBBS_MAIL Version 1.0'
X
X     .Severity  fatal
X
X`09INTSTKOVR    <Internal error, stack overflow>
X`09STKEMPTY     <Internal error, stack empty>
X`09BADSTKELE    <Internal error, bad element found on stack>
X
X     .Severity`09error
X
X`09FILOPNERR    <Unable to open file "UBBS_DATA:!AS">/FAO=1
X`09NOSUCHUSER   <No such user exists in USERLOG.DAT>
X`09MESREAERR    <Error reading intermediate message file, status = !UL>/FAO=
V1
X        UNKFUNC      <Foreign MAIL protocol invoked with unknown function !U
VL.>/FAO=1
X
X    .Severity`09warning
X
X        USERNOEXIST  <Specified user "!AS" does not exist>/FAO=1
X
X    .Severity`09information
X
X`09PUBLMESS     <Public message delivered to "!AS">/FAO=1
X
X     .End
$ CALL UNPACK [.MAIL_PROTOCOL]UBBS_MAIL_ERR.MSG;7 796878843
$ create 'f'
Xcccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
Vcccc
Xc
Xc`09UBBS utilities - Convert_files.for
Xc`09This program converts the FILES.DAT files into FILES.IDX files for
Xc`09UBBS Rev. 4.0
Xc`09Dale Miller - UALR
Xc`0927-Jun-1986
Xc
Xc`09Rev. 4.0  27-Jun-1986
Xc`09Rev. 6.0  06-Jun-1988
Xcccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
Vcccc
X`09implicit none
X`09include 'bbs_inc.for'
X`09character cdate*9,cdate2*11
X`09integer str$upcase,istat,sys$bintim,txtlen
X
X`09record/file_description/ fd
X
X`09open(unit=1,file='files.dat',readonly,shared,status='old')
X
X`09open(unit=2,file='files.idx',status='new',organization='indexed',
X`091   access='keyed',recl=192,form='unformatted',
X`092   recordtype='variable',key=(1:18:character))
X
X 1001`09format(a18,i3,1x,a1,6x,a9,1x,q,a)
X 1002`09format(67x,a11)
X
X`09fd.file_name='$Header'
X`09fd.upload_name='DALE MILLER'
X`09fd.keywords=' '
X`09fd.times_down=0
X`09fd.upload_text=' '
X`09read(1,1002)cdate2
X`09istat = str$upcase(cdate2,cdate2)
X`09istat = sys$bintim(cdate2//' 00:00:00.00',fd.upload_date)
X`09write(2)fd
X`09read(1,1001)fd.file_name
X
X`09fd.upload_name=' '
X`09fd.keywords=' '
X`09fd.times_down=0
X
X 0010`09read(1,1001,end=99)fd.file_name,fd.file_size,
X`091   fd.file_type,cdate,txtlen,fd.upload_text
X`09fd.upload_text(txtlen+1:txtlen+1)=char(cr)
X`09istat = str$upcase(cdate,cdate)
X`09istat = sys$bintim(cdate(1:7)//'19'//
X`091   cdate(8:9)//' 00:00:00.00',fd.upload_date)
X`09print*,'file='//fd.file_name//' type='//fd.file_type//' date='//
X`091   cdate
X`09print*,'file_size=',fd.file_size
X`09write(2)fd
X`09go to 10
X 0099`09print*,'finished'
X`09end
$ CALL UNPACK [.UPGRADE]CONVERT_FILES.FOR;2 571816888
$ create 'f'
Xcccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
Vcccc
Xc
Xc`09UBBS utilities - Crlf.for
Xc`09Redo the userlog for UBBS V 3.0
Xc`09Dale Miller - UALR
Xc`0910-Feb-1985
Xc
Xcccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
Vcccc
X`09implicit none
X`09include 'bbs_inc.for'
X`09include 'sys$library:foriosdef'
X`09integer istat,str$upcase,sys$gettim,sys$asctim
X`09character null4*4,lfcr*4,dummy_20*20
X`09real*8 null8/'0000000000000000'x/
X
X`09character  zz*1,appstr*12
X`09character*40 zeros/'0000000000000000000000000000000000000000'/
X`09null4=char(0)//char(0)//char(0)//char(0)
X`09lfcr=char(10)//char(13)//char(255)//' '
X
X`09open(unit=1,file='userlog.dat',status='old',`09
X`091   organization='indexed',access='keyed',
X`092   recordtype='fixed',recl=50,shared)
X
X`09ur.user_key=char(0)
X`09
X 0010`09read(1,keygt=ur.user_key,iostat=ios)ur
X`09if(ios.eq.for$ios_sperecloc) go to 10
X`09if(ios.ne.0) go to 5000
X`09if(ur.user_key.eq.zeros) go to 10
X 0011`09if(ur.approved) then
X`09    appstr='* Approved *'
X`09else
X`09    appstr='Not Approved'
X`09endif
X
Xc`09write(6,1000)ur.user_key,ur.city,ur.state,ur.phone_number(1:3),
Xc`091   ur.phone_number(4:6),ur.phone_number(7:10),ur.computer,
Xc`092   ur.last_log_date,ur.last_log_time,ur.num_logon,appstr
X
X 1000`09format(1x,a,1x,a,','a,1x,'(',a,')',a,'-',a,/,
X`091   1x,a,1x,a,1x,a,i6,/,1x,a)
X
X`09if(ur.user_crlf.eq.null4) then
X`09    ur.user_crlf=char(13)//char(10)//char(255)
X`09    print*,'bad cr '//ur.user_key
X`09    endif
X`09if(ur.user_ff.eq.null4) then
X`09    ur.user_ff=char(13)//char(10)//char(255)
X`09    print*,'bad ff '//ur.user_key
X`09    endif
X`09if(ur.user_crlf.eq.lfcr) then
X`09    ur.user_crlf=char(13)//char(10)//char(255)
X`09    print*,'flip cr '//ur.user_key
X`09    endif
X`09if(ur.user_ff.eq.lfcr) then
X`09    ur.user_ff=char(13)//char(10)//char(255)
X`09    print*,'flip ff '//ur.user_key
X`09    endif
X`09if(ur.last_pass_chg.eq.null8) then
X`09    istat=sys$gettim(%ref(ur.last_pass_chg))
X`09    istat=sys$asctim(,dummy_20,%ref(ur.last_pass_chg),)
X`09    print*,'bad password change date '//ur.user_key,dummy_20
X`09    endif
X
X`09rewrite(1,err=90500,iostat=ios)ur
X`09go to 10
X
X 5000`09close(unit=1)
X`09print*,'ios=',ios
X`09print*,'finished'
X`09stop
X
X90500`09print*,'an error has occurred'
X`09print*,'ios=',ios
X`09stop
X`09end
$ CALL UNPACK [.UPGRADE]CRLF.FOR;1 940207298
$ create 'f'
X`09program cvtv6
Xcccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
Vcccc
Xc
Xc`09UBBS utilities - Cvtv6.for
Xc`09This program removes converts the FILES.IDX files for UBBS V6.0
Xc
Xc`09Dale Miller - UALR
Xc
Xc`09Rev. 6.0  06-Jun-1988
Xc
Xcccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
Vcccc
X`09implicit none
X`09include 'bbs_inc.for'
X`09include '($rmsdef)'
X`09include 'sys$library:foriosdef.for/nolist'
X`09character filnam1*100,filnam2*100,darea*3,tempfile*50,dsp*1
X`09integer d1,d2,dummy,istat,fc1,fc2,du1,du2,i,length
X`09integer lib$find_file
X`09integer str$trim,str$upcase,sys$gettim
X`09external uopen
X`09record/file_description/ fd
X`09real*8   tempdate
X
X`09call sys$gettim(tempdate)
X`09filnam1='bbs$files:`5B-`5D*.dir;*'
X`09dummy=20
X`09fc1=0
X`09tempfile=filnam1
X`09istat=rms$_nmf
X`09istat=lib$find_file(tempfile,filnam1,fc1)
X`09do while (istat.ne.rms$_nmf)
X`09    d1=1
X`09    do while(d1.ne.0)
X`09`09d1=index(filnam1,'`5D')
X`09`09filnam1=filnam1(d1+1:)
X`09`09end do
X`09    d2=index(filnam1,'.')-1
X`09    darea=filnam1(:d2)
X`09    write(6,1001)' Beginning '//darea
Xc
Xc Get the index file.
Xc
X`09open(unit=4,`09`09shared,
X`091   file='bbs$files:`5B'//darea//'`5Dfiles.idx',
X`092   status='old',`09organization='indexed',
X`093   access='keyed',`09form='unformatted',
X`094   recl=128,`09`09recordtype='fixed',
X`095`09`09`09key=(1:18:character),
X`096   useropen=uopen)
X
X`09open(unit=3,`09`09shared,
X`091   file='bbs$files:`5B'//darea//'`5Dnew_files.idx',
X`092   status='new',`09organization='indexed',
X`093   access='keyed',`09form='unformatted',
X`094   recl=192,`09`09recordtype='variable',
X`095`09`09`09key=(1:18:character))
X
X`09fd.file_name=char(0)
X`09read(4,keygt=fd.file_name,iostat=ios)fd
X`09do while(ios.ne.for$ios_attaccnon)
X`09    fd.archived=.false.
X`09    fd.download_date = tempdate
X`09    fd.keywords(50:79) = ' '
X`09    write(3)fd
X`09    read(4,keygt=fd.file_name,iostat=ios)fd
X`09    end do
X`09    close(unit=4)
X
Xc`09Now, go on to the next directory.
X`09    istat=lib$find_file(tempfile,filnam1,fc1)
X`09    end do
X 1001`09format(a)
X`09stop
X`09end
$ CALL UNPACK [.UPGRADE]CVTV6.FOR;1 1342395196
$ create 'f'
Xcccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
Vcccc
Xc
Xc`09UBBS utilities - Fixmess.for
Xc`09This program add expiration dates to messages created by UBBS
Xc`09previous to version 3.5.  New users may ignore its existance.
Xc`09Dale Miller - UALR
Xc
Xc`09Rev. 3.5  20-Jun-1986
Xcccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
Vcccc
X`09implicit none
X`09include 'bbs_inc.for'
X`09character dummy_20*20
X`09include 'sys$library:foriosdef/nolist'
X`09external uopen
X`09integer k,istat
X`09integer sys$bintim,compquad
X`09real*8  my_time,one_month,time_zero
X
X`09record /mail_header_structure/ mh
X
X`09istat=sys$bintim('18-DEC-1858 00:00:00',one_month)
X`09istat=sys$bintim('19-JUN-1986 00:00:00',time_zero)
X
X`09open(unit=2,file='message.hed',status='old',
X`091    organization='relative',access='direct',shared,
X`092    recordtype='fixed',recl=48,useropen=uopen)
X
X 2100`09read(unit=2,rec=1,iostat=ios)last_header,
X`091   last_data,first_mnum,last_mnum
X`09if(ios.ne.0) then
X`09    print*,'Error on header record ios=',ios
X`09    stop
X`09    end if
X`09print*,'Last header=  ',last_header
X`09print*,'Last data=    ',last_data
X`09print*,'First message=',first_mnum
X`09print*,'Last message= ',last_mnum
X
X`09do k=2,last_header
Xc
Xc`09Loop through all message headers to see if they need fixing
Xc
X `09    read(2,rec=k)mh
X
X`09    if(mh.mail_person) go to 30
X
X`09    dummy_20=mh.mail_date(1:7)//'19'//mh.mail_date(8:9)//' 00:00:00'
X`09    istat=sys$bintim(dummy_20,my_time)
X`09    istat=compquad(my_time,time_zero)
X`09    if(istat.eq.1) go to 30
X`09    call addquad(my_time,one_month,mh.mail_expire)
X`09    write(2,rec=k)mh
X`09    print*,'Fixed ',mh.mail_messnum,' from:'//mh.mail_from//
X`091`09' To:'//mh.mail_to
X 0030`09    continue
X`09    end do
X
X`09close(unit=2)
X`09stop
X 9060`09print*,'could not open file'
X`09stop
X90000`09continue
X`09print*,'Error reading record, ios=',ios
X`09close(unit=2)
X`09close(unit=3)
X`09close(unit=4)
X`09stop
X`09end
X`0C
X`09integer function uopen(fab,rab,lun)
X`09implicit none
X
X`09include '($rabdef)'
X`09include '($fabdef)'
X
X`09record /rabdef/ rab
X`09record /fabdef/ fab
X`09integer sys$open,sys$connect
X
X`09integer lun,status
X`09
Xc`09modify the rab to simplify things
X`09rab.rab$l_rop = ibset(rab.rab$l_rop, rab$v_wat)
X
Xc`09actually open the file
X`09status=sys$open(fab)
X`09if(status) status=sys$connect(rab)
Xc`09return the status
X`09uopen=status
X`09return
X`09end
X`0C
X`09integer function uopen2(fab,rab,lun)
X`09implicit none
X
X`09include '($rabdef)'
X`09include '($fabdef)'
X
X`09record /rabdef/ rab
X`09record /fabdef/ fab
X`09integer sys$open,sys$connect
X
X`09integer lun,status
X`09
Xc`09modify the rab to simplify things
X`09rab.rab$l_rop = ibset(rab.rab$l_rop, rab$v_ulk)
X
Xc`09actually open the file
X`09status=sys$open(fab)
X`09if(status) status=sys$connect(rab)
Xc`09return the status
X`09uopen2=status
X`09return
X`09end
$ CALL UNPACK [.UPGRADE]FIXMESS.FOR;1 2015459162
$ create 'f'
Xcccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
Vcccc
Xc
Xc`09UBBS utilities - Reformat_uploads.for
Xc`09This program reformats binary files uploaded previous to Rev 4.7
Xc`09to conform to the new standard.  It must be invoked for each file
Xc`09to be converted.
Xc`09New users may ignore its existance.
Xc
Xc`09Dale Miller - UALR
Xc
Xc`09Rev. 4.7  09-Dec-1986
Xcccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
Vcccc
X      implicit integer (a-z)
X      character*1024 buff
X      character*70 filnam
X
X      status=lib$get_foreign(filnam,'Enter file name: ',nodlen)
X      if(nodlen.eq.0) go to 100
X      open (unit=1,name=filnam,carriagecontrol='none',
X     1    type='old',err=9000)
X      open (unit=2,name=filnam,carriagecontrol='none',
X     1    type='new',err=9000)
X
X`09length=0
X 0010`09if(length.lt.128) then
X`09    read(1,12,end=500)len2,buff(length+1:)
X`09    length=length+len2
X`09endif
X`09write(2,13)buff(1:128)
X`09buff=buff(129:)
X`09length=length-128
X`09go to 10
X 0500`09if(length.gt.0) then
X`09    buff(length+1:)=' '
X`09    write(2,13)buff(1:128)
X        endif
X`09close(unit=1)
X`09close(unit=2)
X`09call exit
X
X 0012`09format(q,a)
X 0013`09format(a)
X
X 9000`09write(6,*)'could not open file'
X`09call exit
X 0100`09print*,'No file name found'
X`09end
$ CALL UNPACK [.UPGRADE]REFORMAT_UPLOADS.FOR;2 809512967
$ create 'f'
Xcccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
Vcccc
Xc
Xc`09UBBS utilities - Add_files.for
Xc`09This program reads a sequential file containing file descriptions and
Xc`09updates FILES.IDX accordingly.
Xc`09Dale Miller - UALR
Xc`0906-Jun-1988
Xc
Xc`09Rev. 6.0  06-Jun-1988
Xcccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
Vcccc
X`09implicit none
X`09include 'bbs_inc.for'
X`09character cdate*9,cdate2*11,darea*3,infile*80,inline*80,tchar*1
X`09character type*5
X`09integer str$upcase,istat,sys$bintim,txtlen,fsize
X`09external getsize
X`09common/filesize/fsize
X`09record/file_description/ fd
X`09record/file_description/ fd2
X
X`09print*,'Area to update?'
X`09read(*,1003)darea
X`09open(unit=2,file='bbs$files:`5B'//darea//'`5Dfiles.idx',
X`091   status='old',organization='indexed',shared,
X`091   access='keyed',recl=192,form='unformatted',
X`092   recordtype='variable',key=(1:18:character))
X
X`09print*,'Input file name?'
X`09read(*,1003)infile
X`09open(unit=1,file=infile,readonly,shared,status='old')
X
X 1001`09format(a1,a)
X 1002`09format(67x,a11)
X 1003`09format(a)
X
X`09fd.file_name=' '
X`09fd.times_down=0
X`09fd.upload_text=' '
X`09call sys$gettim(fd.upload_date)
X`09fd.download_date = fd.upload_date
X`09fd.archived = .false.
X
X`09read(1,1001,end=99)tchar,inline
X
X 0010`09fd.file_name = inline(1:18)
X`09fd.file_type = inline(20:20)
X`09if(fd.file_type.eq.'A') then
X`09    type = '.asc`5D'
X`09else
X`09    type = '.bin`5D'
X`09end if
X`09fd.upload_name = inline(22:51)
X`09call sys$gettim(fd.upload_date)
X`09fd.download_date = fd.upload_date
X`09fd.archived = .false.
X`09fd.times_down=0
X
X`09read(1,1001,end=99)tchar,fd.keywords
X`09fd.upload_text = fd.keywords
X`09txtlen = 0
X 0011`09read(1,1001,end=99)tchar,inline
X`09if(tchar.eq.'`7E') then
X`09    open(unit=4,file='bbs$files:`5B'//darea//type//
X`091`09fd.file_name,status='old',readonly,
X`092`09useropen=getsize,err=12,iostat=istat)
X`09    close(unit=4)
X`09    fd.file_size = fsize
X`09    print*,'file='//fd.file_name//' type='//fd.file_type//
X`091`09' size=',fd.file_size
X`09    read(2,key=fd.file_name,err=13)fd2
X`09    delete(unit=2)
X
X`09    fd.download_date = fd2.download_date
X`09    fd.upload_date   = fd2.upload_date
X`09    fd.archived      = fd2.archived
X`09    fd.times_down    = fd2.times_down
X 0013`09    write(2)fd
X`09    go to 10
X 0012`09    print*,'Open failed, file='//fd.file_name//' - status=',istat
X`09    go to 10
X`09    end if
X
X`09fd.upload_text(txtlen+1:) = inline
X`09call str$trim(fd.upload_text,fd.upload_text,txtlen)
X`09if(txtlen.ge.400) then
X`09    print*,'********'//fd.file_name//' truncated description'
X`09else
X`09    fd.upload_text(txtlen+1:txtlen+1)=char(cr)
X`09    txtlen = txtlen+1
X`09end if
X`09go to 11
X
X
X 0099`09open(unit=4,file='bbs$files:`5B'//darea//type//
X`091   fd.file_name,status='old',readonly,
X`092   useropen=getsize,err=100,iostat=istat)
X`09close(unit=4)
X`09fd.file_size = fsize
X`09    print*,'file='//fd.file_name//' type='//fd.file_type//
X`091`09' size=',fd.file_size
X`09read(2,key=fd.file_name,err=101)fd2
X`09delete(unit=2)
X 0101`09write(2)fd
X`09go to 102
X
X 0100`09print*,'Open failed, file='//fd.file_name//' - status=',istat
X 0102`09close(unit=1)
X`09close(unit=2)
X`09print*,'finished'
X`09end
X`0C
X`09integer function getsize(fab,rab,lun)
Xc`09This user open finds out the file size.
X
X`09implicit none
X
X`09include '($rabdef)'
X`09include '($fabdef)/list'
X
X`09record /rabdef/ rab
X`09record /fabdef/ fab
X`09integer sys$open,sys$connect
X`09
X`09integer lun,status,fsize
X`09common/filesize/fsize
X`09
Xc`09actually open the file
X`09status=sys$open(fab)
X`09if(status) status=sys$connect(rab)
Xc`09return the status
X`09getsize=status
Xc`09store the size
X`09fsize=fab.fab$l_alq
X`09return
X`09end
$ CALL UNPACK [.UTILITY]ADD_FILES.FOR;2 2087216843
$ create 'f'
X$ define ubbs_data disk$user:`5Bualr_bbs.data`5D
X$ define ubbs_files psi$dua106:`5Bbbs_files.`5D
X$ define ubbs_sysop_1 "DALE MILLER"
X$ define ubbs_sysop_2 "MICHAEL SMITH"
X$ define ubbs_sysop_mail "DOMILLER"
X$! approved_mail_read = 01
X$! approved_mail_send = 02
X$! approved_cb        = 04
X$! approved_file_down = 08
X$! approved_file_up   = 16
X$ define ubbs_flags 25
$ CALL UNPACK [.UTILITY]ASSIGN.COM;2 1195448397
$ create 'f'
X$ bbs
X$ set verify
X$ on error then continue
X$fort/check=noover BBS
X$ on error then continue
X$fort/check=noover BBSCB
X$ on error then continue
X$fort/check=noover SYSOP
X$ on error then continue
X$fort/check=noover UBBS_SUBS
X$ on error then continue
X$macro quadmath
X$ LIBRARY/OBJECT/CREATE UBBS *.OBJ
X$ on error then continue
X$ link/notrace/EXEC=BBS UBBS/INCLUDE=(BBS_MAIN)/LIBRARY
$ CALL UNPACK [.UTILITY]COMPILE.COM;11 492907203
$ create 'f'
X$SET NOVERIFY
X$ DEFINE UBBS_DATA DISK$USER:`5BUALR_BBS.DATA`5D
X$ DEFINE UBBS_FILES DUA10:`5BBBS_FILES.`5D
X$ SET DEFAULT DISK$USER:`5BBBS`5D
X$ IF F$SEARCH("UBBS_DATA:TO_RESTORE.DAT") .EQS. "" THEN EXIT
X$ RENAME UBBS_DATA:TO_RESTORE.DAT `5B`5DTO_RESTORE.DAT
X$ APPEND TO_RESTORE.DAT;0 RESTORED.DAT
X$ SORT/NODUPLICATES TO_RESTORE.DAT TO_RESTORE.DAT
X$ FILES == F$LOGICAL("UBBS_FILES")
X$ FF = F$EXTRACT(F$LOCATE(":",FILES)+1,999,FILES)
X$ SHO SYM FF
X$ FF = F$EXTRACT(0,F$LENGTH(FF)-1,FF)
X$ DISK = F$EXTRACT(0,F$LOCATE(":",FILES)+1,FILES)
X$ OPEN/READ INFILE TO_RESTORE.DAT
X$ OPEN/WRITE OUTFILE FILELIST.DAT
X$ IBM = 0
X$ PCS = 0
X$ AOTHER = 0
X$ OTHER = 0
X$ LOOP:
X$ READ/END=EOF_INPUT INFILE INREC
X$ TYPE = F$EXTRACT(1,3,INREC)
X$ IF TYPE .EQS. "IBM" THEN IBM=IBM+1
X$ IF TYPE .EQS. "PCS" THEN PCS=PCS+1
X$ IF F$EXTRACT(0,1,TYPE) .EQS. "A" THEN AOTHER = AOTHER + 1
X$ IF (TYPE .NES. "IBM") .AND. (TYPE .NES. "PCS") .AND. -
X    (F$EXTRACT(0,1,TYPE) .NES. "A") THEN OTHER = OTHER+1
X$ INREC = FF+F$EXTRACT(1,F$LOCATE(" ",INREC)-1,INREC)
X$ WRITE OUTFILE INREC
X$ GOTO LOOP
X$ EOF_INPUT:
X$ CLOSE INFILE
X$ CLOSE OUTFILE
X$!
X$!`09PROCESS EACH OF THE 3 TAPES
X$!
X$ WRITE SYS$OUTPUT IBM," IBM FILES"
X$ WRITE SYS$OUTPUT PCS," PCS FILES"
X$ WRITE SYS$OUTPUT AOTHER," A-OTHER FILES"
X$ WRITE SYS$OUTPUT OTHER," OTHER FILES"
X$ SET VERIFY
X$ALOCWAIT MF TAPE_DRIVE
X$ IF IBM .EQ. 0 THEN GOTO NOIBM
X$!
X$FINDTAPE UBBS_IBM
X$MOUNT/BLOCK=32766/COMMENT="READ ONLY" TAPE_DRIVE 'TAPE'
X$RDBACK/LOG TAPE_DRIVE:IBM.BCK DISK$TEMP:`5BUALR_BBS`5DIBM.BCK FILELIST.DAT
X$ ON ERROR THEN CONTINUE
X$BACKUP DISK$TEMP:`5BUALR_BBS`5DIBM.BCK/SAVE_SET 'DISK'`5B*...`5D*.*;*/OWNER
V=ORIG
X$DISMOUNT TAPE_DRIVE
X$!
X$NOIBM:
X$!
X$IF PCS .EQ. 0 THEN GOTO NOPCS
X$FINDTAPE/gen=99 UBBS_PCS
X$MOUNT/BLOCK=32766/COMMENT="READ ONLY" TAPE_DRIVE 'TAPE'
X$RDBACK/LOG TAPE_DRIVE:PCS.BCK DISK$TEMP:`5BUALR_BBS`5DPCS.BCK FILELIST.DAT
X$ ON ERROR THEN CONTINUE
X$BACKUP DISK$TEMP:`5BUALR_BBS`5DPCS.BCK/SAVE_SET 'DISK'`5B*...`5D*.*;*/OWNER
V=ORIG
X$DISMOUNT TAPE_DRIVE
X$!
X$NOPCS:
X$IF AOTHER .EQ. 0 THEN GOTO NOAOTHER
X$FINDTAPE/gen=99 UBBS_AFILES
X$MOUNT/BLOCK=32766/COMMENT="READ ONLY" TAPE_DRIVE 'TAPE'
X$!
X$RDBACK/LOG TAPE_DRIVE:AMI.BCK DISK$TEMP:`5BUALR_BBS`5DAMI.BCK FILELIST.DAT
X$RDBACK/LOG TAPE_DRIVE:APP.BCK DISK$TEMP:`5BUALR_BBS`5DAPP.BCK FILELIST.DAT
X$RDBACK/LOG TAPE_DRIVE:AST.BCK DISK$TEMP:`5BUALR_BBS`5DAST.BCK FILELIST.DAT
X$RDBACK/LOG TAPE_DRIVE:ATA.BCK DISK$TEMP:`5BUALR_BBS`5DATA.BCK FILELIST.DAT
X$!
X$DISMOUNT TAPE_DRIVE
X$!
X$ ON ERROR THEN CONTINUE
X$BACKUP DISK$TEMP:`5BUALR_BBS`5DAMI.BCK/SAVE_SET 'DISK'`5B*...`5D*.*;*/OWNER
V=ORIG
X$ ON ERROR THEN CONTINUE
X$BACKUP DISK$TEMP:`5BUALR_BBS`5DAPP.BCK/SAVE_SET 'DISK'`5B*...`5D*.*;*/OWNER
V=ORIG
X$ ON ERROR THEN CONTINUE
X$BACKUP DISK$TEMP:`5BUALR_BBS`5DAST.BCK/SAVE_SET 'DISK'`5B*...`5D*.*;*/OWNER
V=ORIG
X$ ON ERROR THEN CONTINUE
X$BACKUP DISK$TEMP:`5BUALR_BBS`5DATA.BCK/SAVE_SET 'DISK'`5B*...`5D*.*;*/OWNER
V=ORIG
X$!
X$NOAOTHER:
X$IF OTHER .EQ. 0 THEN GOTO NOOTHER
X$FINDTAPE UBBS_FILES
X$MOUNT/BLOCK=32766/COMMENT="READ ONLY" TAPE_DRIVE 'TAPE'
X$!
X$RDBACK/LOG TAPE_DRIVE:100.BCK DISK$TEMP:`5BUALR_BBS`5D100.BCK FILELIST.DAT
X$RDBACK/LOG TAPE_DRIVE:128.BCK DISK$TEMP:`5BUALR_BBS`5D128.BCK FILELIST.DAT
X$RDBACK/LOG TAPE_DRIVE:COM.BCK DISK$TEMP:`5BUALR_BBS`5DCOM.BCK FILELIST.DAT
X$RDBACK/LOG TAPE_DRIVE:CPM.BCK DISK$TEMP:`5BUALR_BBS`5DCPM.BCK FILELIST.DAT
X$RDBACK/LOG TAPE_DRIVE:MAC.BCK DISK$TEMP:`5BUALR_BBS`5DMAC.BCK FILELIST.DAT
X$RDBACK/LOG TAPE_DRIVE:MIS.BCK DISK$TEMP:`5BUALR_BBS`5DMIS.BCK FILELIST.DAT
X$RDBACK/LOG TAPE_DRIVE:TRS.BCK DISK$TEMP:`5BUALR_BBS`5DTRS.BCK FILELIST.DAT
X$!
X$DISMOUNT TAPE_DRIVE
X$!
X$ ON ERROR THEN CONTINUE
X$BACKUP DISK$TEMP:`5BUALR_BBS`5D100.BCK/SAVE_SET 'DISK'`5B*...`5D*.*;*/OWNER
V=ORIG
X$ ON ERROR THEN CONTINUE
X$BACKUP DISK$TEMP:`5BUALR_BBS`5D128.BCK/SAVE_SET 'DISK'`5B*...`5D*.*;*/OWNER
V=ORIG
X$ ON ERROR THEN CONTINUE
X$BACKUP DISK$TEMP:`5BUALR_BBS`5DCOM.BCK/SAVE_SET 'DISK'`5B*...`5D*.*;*/OWNER
V=ORIG
X$ ON ERROR THEN CONTINUE
X$BACKUP DISK$TEMP:`5BUALR_BBS`5DCPM.BCK/SAVE_SET 'DISK'`5B*...`5D*.*;*/OWNER
V=ORIG
X$ ON ERROR THEN CONTINUE
X$BACKUP DISK$TEMP:`5BUALR_BBS`5DMAC.BCK/SAVE_SET 'DISK'`5B*...`5D*.*;*/OWNER
V=ORIG
X$ ON ERROR THEN CONTINUE
X$BACKUP DISK$TEMP:`5BUALR_BBS`5DMIS.BCK/SAVE_SET 'DISK'`5B*...`5D*.*;*/OWNER
V=ORIG
X$ ON ERROR THEN CONTINUE
X$BACKUP DISK$TEMP:`5BUALR_BBS`5DTRS.BCK/SAVE_SET 'DISK'`5B*...`5D*.*;*/OWNER
V=ORIG
X$!
X$NOOTHER:
X$DEALLOCATE TAPE_DRIVE
X$EXIT
$ CALL UNPACK [.UTILITY]DAILY_RESTORE.COM;2 1700535198
$ create 'f'
X`09program INIT_IDX
Xcccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
Vcccc
Xc
Xc`09UBBS utilities  -  INIT_IDX
Xc`09This routine will initialize the FILES.IDX file for a download area.
Xc`09Dale Miller - UALR
Xc
Xc
Xc`09Rev. 4.3  01-Aug-1986
Xc
Xcccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
Vcccc
X`09implicit none
X`09include 'bbs_inc.for'
X`09integer istat
X`09integer sys$gettim
X
X`09record/file_description/ fd
X
Xc`09Open the new indexed file.
X`09open(unit=4,`09`09shared,
X`091   file='files.idx',
X`092   status='new',`09organization='indexed',
X`093   access='keyed',`09form='unformatted',
X`094   recl=192,`09`09recordtype='variable',
X`095`09`09`09key=(1:18:character))
X
X
X`09fd.file_name='$Header'
X`09istat=sys$gettim(fd.upload_date)
X`09fd.upload_name=' '
X`09fd.upload_text=' '
X`09fd.keywords=' '
X`09write(4)fd
X`09close(4)
X`09end
$ CALL UNPACK [.UTILITY]INIT_IDX.FOR;2 457599999
$ create 'f'
X`09Program init_mess
Xcccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
Vcccc
Xc
Xc`09UBBS utilities - Init_mess.for
Xc`09This program initializes the message file for creating UBBS.
Xc`09Dale Miller - UALR
Xc`0914-Nov-1985
Xc
Xcccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
Vcccc
X`09implicit none
X`09character*80 spaces/' '/
X`09integer i
X`09include 'bbs_inc.for'
X`09
X`09record/mail_header_structure/ mh
X
X`09open(unit=2,file='message.hed',status='new',
X`091   organization='relative',access='direct',
X`092   recordtype='fixed',recl=48)
X
X`09open(unit=3,file='message.dat',status='new',`09
X`091   organization='relative',access='direct',
X`092   recordtype='fixed',recl=20)
X
Xc`09write the first record in the message header file
X`09last_header=1
X`09last_data=0
X`09first_mnum=0
X`09last_mnum=0
X`09write(2,rec=1)last_header,last_data,first_mnum,last_mnum
X
Xc`09write the rest of the records
X`09mh.mail_to=' '
X`09mh.mail_from=' '
X`09mh.mail_subject=' '
X`09mh.mail_date=' '
X`09mh.mail_time=' '
X`09mh.mail_section=0
X`09mh.mail_first=0
X`09mh.mail_last=0
X`09mh.mail_messnum=99999999
X`09mh.mail_private=.false.
X`09mh.mail_read=.false.
X`09mh.mail_deleted=.true.
X`09mh.mail_person=.false.
X`09mh.mail_reply_to=0
X`09do i=1,10
X`09    mh.mail_replys(i)=0
X`09    end do
X
X`09do i=2,1000
X`09    write(2,rec=i)mh
X`09    end do
X
X`09do i=1,5000
X`09    write(3,rec=i)spaces
X`09    end do
X
X`09print*,'The message files have been initialized.'
X`09stop
X`09end
$ CALL UNPACK [.UTILITY]INIT_MESS.FOR;2 241912306
$ create 'f'
X`09Program init_userlog
Xcccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
Vcccc
Xc
Xc`09This program initializes the userlog.
Xc
Xcccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
Vcccc
X
X`09character*40 zeros/'0000000000000000000000000000000000000000'/
X`09character*9 bull_date/'01-Jan-00'/
X`09integer*4 high_bull/0/
X`09integer*4 user_number/0/
X
X`09open(unit=1,file='userlog.dat',status='new',
X`091   organization='indexed',access='keyed',
X`092   recordtype='fixed',recl=50,shared,
X`093   key=(1:40:character))
X`09
X`09write(1)zeros,user_number,high_bull,
X`091    bull_date
X`09close(unit=1)
X`09print*,'The USERLOG.DAT file has been initialized.'
X`09stop
X`09end
$ CALL UNPACK [.UTILITY]INIT_USERLOG.FOR;2 492970626
$ create 'f'
X$ mcr install
Xubbs/delete
Xubbs/open/shared/header/priv=(detach,world,oper,sysnam,prmmbx,altpri)
X/exit
X$ deassign/system UBBS_STATUS
$ CALL UNPACK [.UTILITY]INSTBBS.COM;2 778393947
$ create 'f'
X$ link/notrace/EXEC=BBS UBBS/INCLUDE=(BBS_MAIN)/LIBRARY
X$ link/exec=sysop ubbs/include=(sysop)/library
$ CALL UNPACK [.UTILITY]L.COM;2 2136229065
$ create 'f'
X$ link/EXEC=BBS UBBS/INCLUDE=(BBS_MAIN)/LIBRARY
X$ link/exec=sysop ubbs/include=(sysop)/library
$ CALL UNPACK [.UTILITY]LT.COM;2 1879659445
$ create 'f'
X*DOMILLER* * * T E @`5BUALR_BBS`5DSYSOP_REPLY.COM
X*DOMILLER* * * T Q
X* * * A F DOMILLER
X* * * A Q
$ CALL UNPACK [.UTILITY]MAIL.DELIVERY;3 1211850481
$ create 'f'
Xcccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
Vcccc
Xc
Xc`09This program allows adding a message to UBBS from a file.
Xc
Xc`09Begun: 19-Jul-1985
Xc`09Dale Miller - University of Arkansas at Little Rock
Xc`09Rev. 1.0  01-Jan-1988
Xc
Xcccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
Vcccc
X`09implicit none
X`09include 'bbs_inc.for/nolist'
X`09character last_name*20,first_name*20
X`09character zmail_from*30
X`09character zfirst_name*20,zlast_name*20,zmail_to*30,qmail_to*30
X`09character zmail_subject*30
X`09integer i,j,k,l,ii,jj,kk,ll
X`09integer kmess,irec,krec,slen,num_flags
X`09integer status,next_mess,fmess,lmess,mess,mnum
X`09logical*1 busy
X
X`09external uopen
X
X`09record /userlog_structure/ zur
X`09record /mail_header_structure/ mh
X
Xc
X
X 1001`09format(a)
X 1002`09format(i1)
Xc`09open the userlog and message files
X`09open(unit=1,file='ubbs_data:userlog.dat',status='old',`09
X`091   organization='indexed',access='keyed',
X`092   recordtype='fixed',recl=50,shared,useropen=uopen)
X`09open(unit=2,file='ubbs_data:message.hed',status='old',`09
X`091   organization='relative',access='direct',
X`092   recordtype='fixed',recl=48,shared,useropen=uopen)
X`09open(unit=3,file='ubbs_data:message.dat',status='old',`09
X`091   organization='relative',access='direct',
X`092   recordtype='fixed',recl=20,shared,useropen=uopen)
X
X
Xc`09Read a message from MAIL_FILE, and add it to the message section.
Xc`09The first line is the FROM: name.
Xc`09The second line is the TO: name
Xc`09The third line is the section number
Xc`09The fourth line is the SUBJECT: line
Xc`09Remaining lines are the message
X`09open(unit=4,file='mail_file',status='old',carriagecontrol='none')
X
X`09read(4,1001)mail_name
X`09read(4,1001)zmail_to
X`09read(4,1002)mh.mail_section
X`09read(4,1001)mh.mail_subject
X
X`09mh.mail_private=.true.
X`09mh.mail_person=.true.
X
X
X`09do i=1,20
X`09    read(4,1001,end=3090)message(i)
X`09    ii=i
X`09    end do
X
X
X3090`09read(2,rec=1)last_header,last_data,
X`091   first_mnum,last_mnum,busy
X`09if(busy) then
X`09    unlock(unit=2)
X`09     call lib$wait(1.0)
X`09    go to 3090
X`09    end if
X
X`09last_header=last_header+1
X`09last_mnum=last_mnum+1
X`09write(2,rec=1)last_header,last_data+ii,
X`091   first_mnum,last_mnum,busy
X`09call date(mh.mail_date)
X`09call time(mh.mail_time)
X`09mh.mail_read=.false.
X`09mh.mail_deleted=.false.
X`09mh.mail_to=zmail_to
X`09mh.mail_reply_to=0
X`09do i=1,10
X`09    mh.mail_replys(i)=0
X`09    end do
X`09mh.mail_first=last_data+1
X`09mh.mail_last=last_data+ii
X`09mh.mail_from=mail_name
X`09mh.mail_messnum=last_mnum
X`09write(2,rec=last_header) mh
X
X`09do jj=1,ii
X`09    write(3,rec=last_data+jj)message(jj)
X`09    end do
X
X`09call str$upcase(zmail_to,zmail_to)
X`09jj = index(zmail_to,' ')
X`09zfirst_name=zmail_to(1:jj-1)`09
X`09zlast_name=zmail_to(jj+1:30)
X`09zur.user_key=zlast_name//zfirst_name
X`09
X`09read(1,key=zur.user_key)zur
X`09zur.num_unread=zur.num_unread+1
X`09rewrite(1)zur
X
X`09close(unit=1)
X`09close(unit=2)
X`09close(unit=3)
X`09close(unit=4)
X`09call exit
X`09end
X
$ CALL UNPACK [.UTILITY]MESSAGE.FOR;1 841550426
$ create 'f'
X`09`09`09UBBS file approval/editor.`09`0901-Jan-1988
X----------------------------------------------------------------------------
V----
XEnter ABC.XYZ in response to filename to download in order to access approva
Vl
Xsection.  Functions supported in file approval:
X
X`5BA`5Dpprove   `5BD`5Delete   `5BE`5Ddit   `5BM`5Dove  `5BR`5Dename   `5BW`
V5Drite   e`5BX`5Dit   <CR>
X
X1. Hit return to see the next file without altering the current one.
X2. Use `5BE`5Ddit for changing information in file description header.
X   After editing a description, it must be `5BW`5Dritten.
X3. To download an unapproved file, just download as usual.  The files are th
Vere,
X   although, they just don't show up in the general user's file listing unti
Vl
X   approved.
X4. To add a file to the listing, approve it then `5BW`5Drite it.
X5. `5BR`5Dename changes the name of the file, `5BM`5Dove will move it to ano
Vther
X   section but retain the file name.
X----------------------------------------------------------------------------
V----
X
XExample session:
X
XLast logon on 24-JUL-86 at 11:11:08
XYou have signed on   737 times.
XThe last message you read was 110415
X      Current last message is 110427
X          You are user number  94404
X
XThere are   6 bulletins today.  Last bulletin was 23-Jul-1986
X11:19:44-05 Command (B,C,E,F,G,H,K,M,P,R,S,U,W,X,?)?F`0D
X(D)ownload, (U)pload, (H)elp or (E)xit? `5Bexit`5D D`0D
XArea? AMI`0D
+-+-+-+-+-+-+-+-  END  OF PART 10 +-+-+-+-+-+-+-+-