-+-+-+-+-+-+-+-+ START OF PART 6 -+-+-+-+-+-+-+-+
X`09    flow=to_vax
X`09    call clear_counts()
X`09    call default_parameters()
X`09    timeout_count=10
X`09    retry_limit=5
X`09    write(6,1001)crlf(:cl)//
X`091`09'Beginning Kermit upload.'
X`09    call waitabit('2')
X`09    call init_timer(file_timer)
X`09    dummyl=get_vaxfile(filnam)
X`09    dummyl = kermit_receive(ldesc, rbuffer, xbuffer)
X`09    call waitabit('10')
X`09    call elapsed_time(file_timer)`09!Display elapsed time
X`09    call report_totals()`09`09!Report final stats
X`09    if(dummyl) then
X`09`09write(6,1001)crlf(:cl)//'Successful transfer'
X`09`09go to 4800
X`09    else
X`09`09write(6,1001)crlf(:cl)//'Transfer failed.'//bell
X`09`09istat=lib$delete_file(filnam//';*')
X`09    end if
X`09else`09`09`09!ascii upload
X`09    flow=to_vax
X`09    dummyl=get_vaxfile(filnam)
X`09    call out('Ascii files must not contain any non-printable',*4739)
X`09    call out('characters, and must not have any lines over',*4739)
X`09    call out('200 characters in length.',*4739)
X`09    call out('Each line must be terminated by a carriage',*4739)
X`09    call out('return.  The BBS will add a line feed for each',*4739)
X`09    call out('line you send.',*4739)
X`09    call out('Control-z to end, Control-c to abort.',*4739)
X 4739`09    write(6,1001)crlf(:cl)//crlf(:cl)//bell//
X`091`09'Start your file send now.'
X`09    write(6,1001)crlf(:cl)
X 4740`09    length=-200
X`09    call get_uplow_string(line,length)
X`09    if(length.lt.0) go to 4750
X`09    call send_cr()
X`09    call send_lf()
X`09    if(length.eq.0) then
X`09`09write(file_unit,1001)' '
X`09    else
X`09`09write(file_unit,1001)line(1:length)
X`09    end if
X`09    go to 4740
X
X 4750`09    if(length.eq.-1) then
X`09`09close(unit=file_unit)
X`09`09write(6,1001)crlf(:cl)//'Successful upload!'
X`09`09go to 4800
X`09    else
X`09`09close(unit=file_unit,disp='delete')
X`09`09write(6,1001)crlf(:cl)//bell//'Upload aborted'
X`09    end if
X`09end if
X`09go to 4900
X
X 4800`09continue`09! get file description
X`09write(6,1001)crlf(:cl)//'Please give a 1-line description of the'
X`09write(6,1001)crlf(:cl)//'file for the download directory.'
X`09write(6,1001)crlf(:cl)//'?'
X`09dummy=40
X`09call get_uplow_string(line,dummy)
X`09if(dummy.eq.0.or.line.eq.' ') go to 4800
X
Xc`09find out how big the file is.  This useropen will put the file
Xc`09size into fsize.
X`09open(unit=4,file=filnam,status='old',readonly,
X`091   useropen=getsize)
X`09close(unit=4)
X
Xc`09Format a message and send to the operator.
X`09open(unit=4,file='mail.tmp',status='new',
X`091    carriagecontrol='list')
X`09istat=str$trim(filnam,filnam,dummy)
X`09write(4,1001)'File name='//filename
X`09write(4,1001)'From:'//mail_name//' Stored as:'//zfilnam
X`09write(4,1001)'$rename '//filnam(1:dummy)//
X`091   ' ubbs_files:`5B'//darea//binasc//'`5D'//filename(1:flen)
X`09write(4,1004)darea,filename(1:18),fsize,ftyp//cdate//
X`091   ' '//line(1:dummy)
X `09close(unit=4)
X`09istat = lib$spawn('mail/subject="upload" mail.tmp sysop')
X`09go to 4900`09!finished
X`20
X 4900`09continue
X`09return
X`09end
X`0C
X`09subroutine listcat(darea)
Xcccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
Vcccc
Xc
Xc`09UBBS subroutines
Xc`09This routine will give the directory of files for a download area
Xc`09Dale Miller - UALR
Xc
Xc
Xc`09Rev. 4.0  27-Jun-1986
Xc`09Rev. 4.5  24-Sep-1986
Xc`09Rev. 6.0  06-Jun-1988
Xc
Xcccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
Vcccc
X`09implicit none
X`09include 'bbs_inc.for'
X`09character*(*) darea
X`09character cdate*11,filtyp*6,startoff*18
X`09integer length,dummy
X`09real*8 long_ago
X`09logical short
X
X`09integer istat,keyln
X`09integer compquad
X`09integer sys$asctim,sys$bintim,str$upcase,str$trim
X`09external uopen
X
X`09record/file_description/ fd
X
X`09short=.true.
X`09write(6,1001)crlf(:cl)//'Do you want a short or a long listing?'//
X`091   ' `5BShort`5D'
X`09dummy=5
X`09call get_upcase_string(startoff,dummy)
X`09if(startoff(1:1).eq.'L') short=.false.
X
X`09write(6,1001)crlf(:cl)//'Enter earliest date of files you'//
X`091   ' wish to see.'//crlf(:cl)//
X`092   'The date must be dd-mmm-yyyy (e.g. 19-APR-1986)'//
X`093   crlf(:cl)//'Or enter <cr> for a all dates.'//
X`094   crlf(:cl)//'?'
X`09dummy=11
X`09call get_uplow_string(cdate,dummy)
X`09if(dummy.eq.0) cdate='01-JUL-1985'
X`09istat=str$upcase(cdate,cdate)
X`09istat = sys$bintim(cdate(:11)//' 00:00:00.00',long_ago)
X`09write(6,1001)crlf(:cl)//
X`091   'Enter the starting file name or <cr> for beginning :'
X`09dummy=18
X`09startoff=char(0)
X`09call get_filnam_string(startoff,dummy)
X`09if(startoff.eq.' ') startoff='.'
X`09cdate(5:5)=char(ichar(cdate(5:5))+32)
X`09cdate(6:6)=char(ichar(cdate(6:6))+32)
X`09write(6,1001)crlf(:cl)//'    Files since: '//cdate(:11)
X`09call ctrl_o_check(*10,*10)
X
Xc`09Open the indexed file for reading.
X`09open(unit=4,`09`09shared,
X`091   file='ubbs_files:`5B'//darea//'`5Dfiles.idx',
X`092   status='old',`09organization='indexed',
X`093   access='keyed',`09form='unformatted',
X`094   recl=192,`09`09recordtype='variable',
X`095   readonly,`09`09key=(1:18:character),
X`096   useropen=uopen)
X
X`09fd.file_name='$Header'
X`09read(4,key=fd.file_name,err=100)fd
X`09istat = sys$asctim(,cdate,fd.upload_date,)
X
X`09cdate(5:5)=char(ichar(cdate(5:5))+32)
X`09cdate(6:6)=char(ichar(cdate(6:6))+32)
X`09write(6,1001)crlf(:cl)//'Last file added: '//cdate(:11)
X`09call ctrl_o_check(*10,*10)
X
X 0100`09fd.file_name=startoff
X`09read(4,keygt=fd.file_name,iostat=ios)fd
X`09do while (ios.eq.0)
X`09    call ctrl_o_check(*10,*10)
X`09    if(fd.file_type.eq.'A') then
X`09`09filtyp='Ascii '
X`09    else if(fd.file_type.eq.'B') then
X`09`09filtyp='Binary'
X`09    else
X`09`09go to 110
X`09    end if
X`09    istat=compquad(fd.upload_date,long_ago)
X`09    if(istat.ne.-1 .and. (.not.short)) then
X`09`09write(6,1001)crlf(:cl)//
X`091`09    '************************************************'//
X`092`09    '***********************'//crlf(:cl)
X`09`09istat = sys$asctim(,cdate,fd.upload_date,)
X`09`09cdate(5:5)=char(ichar(cdate(5:5))+32)
X`09`09cdate(6:6)=char(ichar(cdate(6:6))+32)
X`09`09istat=str$trim(fd.keywords,fd.keywords,keyln)
X
X`09    `09write(6,1002)crlf(:cl),fd.file_name,cdate(:11),
X`091`09    (fd.file_size+1)/2,filtyp,fd.times_down,
X`092`09    crlf(:cl)//crlf(:cl),
X`093`09    fd.keywords(:keyln),fd.upload_name//crlf(:cl)
X
X`09`09istat=index(fd.upload_text,char(cr))
X`09`09do while(istat.ne.0)
X`09`09    write(6,1001)crlf(:cl)//fd.upload_text(:istat-1)
X`09`09    call ctrl_o_check(*10,*10)
X`09`09    fd.upload_text=fd.upload_text(istat+1:)
X`09`09    istat=index(fd.upload_text,char(cr))
X`09`09    end do
X`09        end if
X`09    if(istat.ne.-1 .and. short) then
X`09`09istat = sys$asctim(,cdate,fd.upload_date,)
X`09`09cdate(5:5)=char(ichar(cdate(5:5))+32)
X`09`09cdate(6:6)=char(ichar(cdate(6:6))+32)
X`09`09istat=str$trim(fd.keywords,fd.keywords,keyln)
X
X`09    `09write(6,1003)crlf(:cl),fd.file_name,cdate(:11),
X`091`09    (fd.file_size+1)/2,filtyp,fd.keywords(:keyln)
X
X`09        end if
X 0110`09    read(4,keygt=fd.file_name,iostat=ios)fd
X`09    end do
X 0010`09close(unit=4)
X`09return
X 1001`09format(a)
X 1002`09format(a,a18,5x,a11,1x,i5,'K bytes',2x,a6,4x,'Accesses:',i5,a,5x,
X`091   'Keywords: ',a,' By:',a)
X 1003`09format(a,a18,1x,a11,i4,'K ',a6,1x,a)
X`09end
X`0C
X`09subroutine enter_message(length,*,size)
Xcccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
Vcccc
Xc
Xc`09UBBS subroutines
Xc`09This routine handles the entering of messages.
Xc`09Dale Miller - UALR
Xc
Xc
Xc`09Rev. 3.5  19-Jun-1986
Xc`09Rev. 4.8  05-Feb-1987
Xc
Xcccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
Vcccc
X`09implicit none
X`09include 'bbs_inc.for/nolist'
X`09include 'sys$library:foriosdef/nolist'
X
X`09character cdummy*1,string*80,term*5
X`09logical flag
X`09integer*4 i,length,dummy,istat,number,size,current
X`09integer array_edit
Xc`09system routines
X`09integer str$trim
X
X 1001`09format(a)
X 1011`09format(i<dummy>)
X 1013`09format(a,i2,'>')
X 1015`09format(a,i2,1x,a)
X 1024`09format(i5.5)
X
X`09write(term,1024)mod(user_number,100000)
X`09current=0
X`09if(size.eq.0) write(6,1001)crlf(:cl)//crlf(:cl)//
X`091   'Your message may be 1 to 20 80-character lines.'
X`09if((ur.editor.and.1).eq.1) then
X`09    length=0
X`09    call setup_local(.false.)
X`09    call array_edit(message,length,80,20)
X`09    call setup_local(.true.)
X`09    if(length.gt.20) then
X`09`09write(6,1001)crlf(:cl)//'Truncated to 20 lines'
X`09`09length=20
X`09`09end if
X`09    if(length.eq.0) then
X`09`09write(6,1001)crlf(:cl)//'Message aborted.'//bell
X`09`09return 1
X`09`09end if
X`09    go to 3060
X`09    end if
X
X`09write(6,1001)crlf(:cl)//'End your entry with a blank line.'
X`09i=1
X 3040`09do length=i,20
X`09    dummy=80
X`09    if((size.ne.0).and.(size-current.lt.79)) dummy=size-current-1
X`09    write(6,1013)crlf(:cl),length
X`09    call get_uplow_string(message(length),dummy)
X`09    if(dummy.eq.0) go to 3050
X`09    current=current+dummy+1
X`09    if((size.ne.0).and.(current.ge.size)) go to 3050
X`09    end do
X`09length=21
X 3050`09length=length-1`09`09`09!message length
X`09if(length.eq.0) then
X`09    write(6,1001)crlf(:cl)//'Message aborted.'//bell
X`09    return 1
X`09    end if
Xc`09send menu goes here
X 3060`09write(6,1001)crlf(:cl)//crlf(:cl)//'(S)end, (C)ontinue,'//
X`091   ' (A)bort, (L)ine-edit, (F)ull-edit or (E)dit? `5BS`5D '
X`09dummy=1
X`09call get_upcase_string(cdummy,dummy)
X`09if(dummy.eq.0) return
X`09if(cdummy.eq.'A') then`09`09`09! Abort message send
X`09    write(6,1001)crlf(:cl)//'Entry aborted.'//bell`09
X`09    return 1
X`09    endif
X`09if(cdummy.eq.'C') then`09`09`09! Continue entering
X`09    i=length+1
X`09    go to 3040
X`09    endif
X`09if(cdummy.eq.'E'.or.cdummy.eq.'F'.or.cdummy.eq.'L') then ! Edit message
X`09  if((((ur.editor.and.1).eq.1).and.cdummy.ne.'L')
X`091    .or. cdummy.eq.'E') then
X`09    call setup_local(.false.)
X`09    istat=array_edit(message,length,80,20)
X`09    call setup_local(.true.)
X`09    if(length.gt.20) then
X`09`09write(6,1001)crlf(:cl)//'Truncated to 20 lines'
X`09`09length=20
X`09`09end if
X`09    if(length.eq.0) then
X`09`09write(6,1001)crlf(:cl)//'Message aborted.'//bell
X`09`09return 1
X`09`09end if
X`09    go to 3060
X`09  else
X 3069`09    write(6,1001)crlf(:cl)//'Your entry now reads:'
X`09    do i=1,length
X`09`09istat=str$trim(message(i),message(i),dummy)
X`09`09write(6,1015)crlf(:cl),i,message(i)(1:dummy)
X`09`09end do
X`09    write(6,1001)crlf(:cl)
X 3070`09    write(6,1001)crlf(:cl)//
X`091`09'Which line do you wish to change? `5Bexit`5D '
X`09    dummy=2
X`09    flag=.false.
X`09    call get_number(string,dummy,flag)
X`09    if(dummy.eq.0) go to 3060
X`09    read(string,1011)number
X`09    if(number.eq.0) go to 3060
X`09    if(number.gt.length) then
X`09`09write(6,1001)crlf(:cl)//'Invalid line number'
X`09`09go to 3070
X`09`09end if
X`09    write(6,1001)crlf(:cl)//'Line editor activated'
X`09    write(6,1013)crlf(:cl),number
X`09    dummy=80
X`09    call get_edit_string(message(number),dummy)
X`09    go to 3070
X`09  end if
X`09    end if
X`09if(cdummy.eq.'S') then`09`09`09! Save message
X`09    return
X`09    end if
X
Xc`09Otherwise, error.
X`09write(6,1001)crlf(:cl)//bell//'Invalid response..try again.'//bell
X`09go to 3060`20
X
X`09end
X`0C
X`09subroutine get_edit_string (string,len)
Xcccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
Vcccc
Xc
Xc`09UBBS subroutines
Xc`09This routine will perform MS-BASIC type line editing on a string.
Xc`09Dale Miller - UALR
Xc
Xc
Xc`09Rev. 4.8  05-Feb-1987
Xc
Xcccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
Vcccc
X`09implicit none
X`09include 'bbs_inc.for/nolist'
X`09character string*(*),temp3*200
X`09logical*1 back_up(3)/bs,' ',bs/
X`09logical*1 del_stg(3)/'\',' ','\'/
X`09logical*1 to_send(1)
X`09integer tempi,j,i
X`09integer max,len,current,istat
X`09integer str$trim
X`09integer read_byte
X
X 1001`09format(a)
Xc`09Find out current length
X`09istat=str$trim(string,string,current)
X`09max=len
X`09len=0
X`09timeouts=0
X`09temp3=' '
X
Xc`09Initial mode -- no controls entered
X 0010`09continue
X`09tempi=read_byte(60)
X`09if(timeouts.gt.4) call finish_timeout
X`09if(tempi.eq.cr. or. tempi.eq.69 .or.
X`091   tempi.eq.101) then
X`09    go to 50`09`09`09`09!carriage return or 'E'
X`09else if(tempi.eq.bs .or. tempi.eq.rub) then`09!backspace or rubout
X`09    if(len.eq.0) go to 10`09`09`09!nothing to delete
X`09    len=len-1
X`09    call raw_write(back_up,3)
X`09else if(tempi.eq.dc2) then`09`09!Control-r
X`09    call out(temp3(1:len),*10)
X`09else if(tempi.eq.nak .or. tempi.eq.can) then`09! Ctrl-u or ctrl-x
X`09    do j=1,len
X`09`09call raw_write(back_up,3)
X`09`09end do
X`09    len=0
X`09else if(tempi.eq.32) then`09`09! Space - take next char
X`09    if(len.ge.current) go to 10
X`09    len=len+1
X`09    temp3(len:len)=string(len:len)
X`09    to_send(1)=ichar(string(len:len))
X`09    call send_byte(to_send)
X`09else if(tempi.eq.68 .or. tempi.eq.100) then`09! 'D' - delete next char
X`09    if(len.ge.current) go to 10
X`09    del_stg(2)=ichar(string(len+1:len+1))
X`09    call raw_write(del_stg,3)
X`09    string(len+1:)=string(len+2:)
X`09    current=current-1
X`09else if(tempi.eq.63 .or. tempi.eq.105) then`09! 'I' - Insert mode
X`09    go to 0100`09`09`09`09! too involved for inline
X`09else if(tempi.eq.88 .or. tempi.eq.120) then`09! 'X' - extend
Xc`09     Actually, EOL plus I.
X`09    if(current.gt.len) then
X`09`09temp3(len+1:current)=string(len+1:current)
X`09`09write(6,1001)temp3(len+1:current)
X`09`09len=current
X`09`09end if
X`09    go to 0100
X`09else if(tempi.eq.72 .or. tempi.eq.104) then`09! 'H' - Hack
X`09    current=len
X`09    temp3(len+1:)=' '
X`09    string(len+1:)=' '
X`09    go to 0100
X`09end if
X
X`09go to 10
X
X 0050`09continue
X`09if(current.gt.len) then
X`09    temp3(len+1:current)=string(len+1:current)
X`09    write(6,1001)temp3(len+1:current)
X`09    len=current
X`09    end if
X`09string=temp3
X`09return
X
X 0100`09continue`09! Insert mode.  Only allowed control is BS.
X`09tempi=read_byte(60)
X`09if(timeouts.gt.4) call finish_timeout
X`09if(tempi.eq.cr) go to 50`09`09!carriage return
X`09if(tempi.eq.bs .or. tempi.eq.rub) then`09!backspace or rubout
X`09    if(len.eq.0) go to 10`09`09`09!nothing to delete
X`09    len=len-1
X`09    call raw_write(back_up,3)
X`09else if(tempi.eq.dc2) then`09`09!Control-r
X`09    call out(temp3(1:len),*10)
X`09else if(tempi.le.us) then`09`09! Other control
X`09    go to 10
X`09else`09`09`09`09`09! Valid input character
X`09    if(len.ge.max) go to 10
X`09    len=len+1
X`09    temp3(len:len)=char(tempi)
X`09    to_send(1)=tempi
X`09    call send_byte(to_send)
X`09    string(len:)=char(tempi)//string(len:)
X`09    current=current+1
X`09end if
X
X`09go to 100
X
X`09end
X`0C
X`09integer function array_edit(passed_data,passed_length,row,col)
XC+++
XC MODULE NAME:`09array_edit`09FILE NAME: array_edit.for
XC MODULE OVERVIEW:
XC`09This subroutine invokes the EDT editor on an array of
XC`09character data.`20
XC`09Given an array of data (up to max_col lines long), this
XC`09routine will send it to EDT and, upon termination of
XC`09EDT, return the data in a standard FORTRAN character
XC`09array.  Users may use all features of EDT except journal
XC`09files.
XC
XC FORMAL PARAMETERS:
XC`09passed_data : the address of a fixed string descriptor for
XC`09`09`09a FORTRAN character data array. READ/WRITE
XC`09passed_length : the current number of lines filled in the
XC`09`09`09array. READ/WRITE
XC`09row : the width of the array, in bytes (ie, the line length) READ
XC`09col : the length of the array, up to max_col (defined as 100)
XC`09`09 lines long READ
XC
XC CALLS:
XC`09EDT$EDIT : to edit the data.
XC
XC IMPLICIT INPUTS:
XC`09none
XC
XC IMPLICIT OUTPUTS:
XC`09none
XC
XC SIDE EFFECTS:
XC`09any side effects possible with EDT (including "write")
XC
XC COMPLETION CODES:
XC`09SS$_NORMAL -- for normal return
XC`09SS$_BADPARAM -- for illegal parameters
XC`09SS$_INSFMEM -- unable to allocate sufficient virtual memory
XC
XC AUTHOR: jms `09`09CREATION DATE: May 21, 1985
XC MAINTENANCE RECORD: (edit increment number, description, date, initials)
XC`09V1.00-00`09jms`09Original version
XC
XC---
Xc`09Rev. 5.2  17-Oct-1987
Xc
Xcccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
Vccc
X
X
X`09implicit none
X
XC`09arguments
X
X`09character*(*) passed_data(*)`09`09! the passed data block
X`09integer passed_length`09`09`09! how many lines are filled
X`09integer row`09`09`09`09! number of rows in input
X`09integer col`09`09`09`09! number of columns in input
X
XC`09include files
X
XC`09integer*4 max_col`09`09`09! maximum number of columns
X`09parameter max_col = 100`09`09`09! SEE ALSO ARRAY_EDIT
X`09integer*4 length`09`09`09! length of data
X`09integer*4 data(2,max_col)`09`09! DSD for up to 100 records
X`09common /array_edit_common/ length,data`09! common block definition
X`09include '($SSDEF)'
X
XC`09local variables
X
X`09integer`09`09com_data(2,max_col)`09! pointers to string data
X`09integer`09`09null_string(2)`09`09! a null string, for length
X`09integer`09`09cur_len`09`09`09! length of a string
X`09integer`09`09index`09`09`09! do loop index variable
X`09integer`09`09index2`09`09`09! do loop index variable
X`09character*1 `09null_character`09`09! the null character
X`09character*32    ctrl_chrs
X`09integer `09afileio_bpv(2)`09`09! BPV data type for EDT$EDIT
X`09integer`09`09afileio`09`09`09! subroutine to handle I/O
X`09external `09afileio
X
XC`09RTL functions
X
X`09integer`09`09str$left`09`09! extract substring of a string
X`09integer`09`09str$copy_dx`09`09! copy by descriptor src->dst
X`09integer`09`09lib$sget1_dd`09`09! get 1 dynamic string
X`09integer`09`09str$find_first_in_set`09! find 1st char in set of chars
X`09integer`09`09edt$edit`09`09! callable EDT editor`20
X`09integer`09`09str$trim`09`09! remove trailing spaces
X
X`09ctrl_chrs  =  char(00)//char(01)//char(02)//char(03)//char(04)//
X`091   char(05)//char(06)//char(07)//char(08)//char(09)//char(10)//
X`092   char(11)//char(12)//char(13)//char(14)//char(15)//char(16)//
X`093   char(17)//char(18)//char(19)//char(20)//char(21)//char(22)//
X`094   char(23)//char(24)//char(25)//char(26)//char(27)//char(28)//
X`095   char(29)//char(30)//char(31)
X
X`09array_edit = SS$_NORMAL`09`09`09! set default return status
X`09length=passed_length`09`09`09! fill in common block
X`09afileio_bpv(1) = %loc(afileio)`09`09! and create the descriptor
X`09afileio_bpv(2) = 1`09`09`09! for the BPV.
X
XC`09parameter bounds checking.`20
X`09if (col.gt.max_col .or. col.lt.0 .or. row.lt.0 .or.`20
X`091`09passed_length.lt.0) then
X`09`09array_edit = SS$_BADPARAM
X`09`09return
X`09endif
X
XC+++
XC Witness a major kludge -- getting FORTRAN fixed string descriptors
XC to convert to VMS dynamic string descriptors.  For each row in the
XC array, get a dynamic string of length row.  Copy the FORTRAN entry
XC at row I into the dynamic string descriptor, and then shorten
XC the dynamic string to the correct length.
XC---
X`09do index=1,col
X`09`09if (lib$sget1_dd(row,data(1,index)) .ne. SS$_NORMAL) then
X`09`09`09array_edit = SS$_INSFMEM
X`09`09`09return
X`09`09endif
X`09`09call str$trim(data(1,index),
X`091`09    passed_data(index)(1:row),cur_len)
X`09end do
X
XC+++
XC Now, call the editor.
XC---
X`09call edt$edit ( 'an input file',! input file
X`091`09`09'You have entered', ! output file
X`092`09`09'ubbs_data:wordwrap.edt',`09! command file
X`093`09`09,`09`09! journal file
X`094`09`09"44,`09`09! bits 1B5,1B2
X`095`09`09afileio_bpv,`09! fileio routine
X`096`09`09,`09`09! workio routine
X`097`09`09,)`09`09! xlate routine
X
X
XC+++
XC copy the data back into the FORTRAN array, and
XC update the length. Since str$copy_dx signals all
XC errors (except STR$_TRU, which we don't care about
XC anyway), no need to check status. Return from whence we came.
XC---
X`09do index=1,col
X`09    call str$copy_dx( passed_data(index) , data(1,index) )
X`09    end do
X`09do index=1,min(length,col)
X`09    index2=str$find_first_in_set(passed_data(index),ctrl_chrs)
X`09    do while(index2.ne.0)
X`09`09if(index2.eq.1) then
X`09`09    passed_data(index)=passed_data(index)(2:)
X`09`09else
X`09`09    passed_data(index)=passed_data(index)(1:index2-1)//
X`091`09`09passed_data(index)(index2+1:)
X`09`09end if
X`09`09index2=str$find_first_in_set(passed_data(index),ctrl_chrs)
X`09`09end do
X`09    end do
X`09passed_length=length
X`09return
X
X`09end
X`0C
X`09integer function afileio(code, stream, record, rhb)
X
XC+++
XC MODULE NAME:`09afileio`09`09FILE NAME:`09array_edit.for
XC MODULE OVERVIEW:
XC`09This subroutine is passed to the EDT$EDIT subroutine
XC`09to simulate disk i/o. In this way, arrays of data
XC`09can be edited with the EDT editor.
XC
XC FORMAL PARAMETERS:
XC`09code : the action desired (defined by EDTSHR.EXE)
XC`09stream : the file for which "code" action is desired
XC`09record : the record to read/write OR the filename to open
XC`09rhb : the record header block (not VMS) OR the related filename to open
XC
XC IMPLICIT INPUTS:
XC`09from common block /ARRAY_EDIT_COMMON/
XC`09`09length : the length of the data (read/write)
XC`09`09data : the original data (not updated until EDT exits)
XC
XC IMPLICIT OUTPUTS:
XC`09none
XC
XC SIDE EFFECTS:
XC`09none
XC
XC COMPLETION CODES:
XC`09SS$_NORMAL : all normal errors
XC`09RMS$_EOF : for end of file on read
XC`09all other errors are signaled.
XC
XC AUTHOR: jms`09`09CREATION DATE:`09May 21, 1985
XC MAINTENANCE RECORD:
XC`09V1.00-0`09`09Original Version`09JMS
XC
XC---
X
X`09implicit none
X
XC passed arguments
X
X`09integer*4 code`09`09`09`09! code passed in from EDT
X`09integer*4 stream`09`09`09! stream to act upon
X`09integer*4 record(2)`09`09`09! DSD for record
X`09integer*4 rhb(2)`09`09`09! DSD for record header block
X
XC common block definitions
X
XC`09integer*4 max_col`09`09`09! maximum number of columns
X`09parameter max_col = 100`09`09`09! SEE ALSO ARRAY_EDIT
X`09integer*4 length`09`09`09! length of data
X`09integer*4 data(2,max_col)`09`09! DSD for up to 100 records
X`09common /array_edit_common/ length,data`09! common block definition
X`09include 'bbs_inc.for'
XC included libraries and constant files
X
Xc`09include '($ssdef)'
X`09include '($rmsdef)'
X
XC RTL routines
X`09
X`09integer`09`09edt$fileio
X
XC local variables
X
X`09integer`09`09in_ptr`09`09`09!input file pointer
X`09integer`09`09out_ptr`09`09`09!output file pointer
X
X
XC set status initially to be normal
X
X`09afileio = SS$_NORMAL
X
XC+++
XC Determine what to do based on what file is being requested.
XC For most files (all except input and output), we pass the I/O
XC request on to the system EDT$FILEIO routine.  For input and
XC output files, handle the I/O to/from an array. This is particularily
XC easy since the input file is opened and read once, and the output
XC file is opened and written once.
XC---
X
X`09if (stream .eq. edt$k_input_file) then
XC+++
XC Handle case of input file. Check request. Normal requests
XC are to open_input and get.  edt$k_close is also a legal
XC request, which is ignored.  All othe requests are illegal,
XC but we ignore them without returning error conditions.
XC---
X`09`09if (code .eq. edt$k_get) then
XC+++
XC Read data until length lines have been reached.
XC When done, return RMS$_EOF and do not copy.
XC---
X`09`09`09if (in_ptr .gt. length) then
X`09`09`09`09afileio = RMS$_EOF
X`09`09`09else
X`09`09`09`09call str$copy_dx ( record, data(1,in_ptr) )
X`09`09`09`09in_ptr=in_ptr+1
X`09`09`09`09rhb(1)='020E0000'X`09! fix numbers
X`09`09`09endif
X
X`09`09else if (code .eq. edt$k_open_input) then
XC+++
XC Reset input pointer to 1 when opening input file
XC---
X`09`09`09in_ptr=1
X
X`09`09else if (code .eq. edt$k_open_output_seq) then
X
X`09`09`09continue`09`09`09`09! error
X
X`09`09else if (code .eq. edt$k_open_output_noseq) then
X
X`09`09`09continue`09`09`09`09! error
X
X`09`09else if (code .eq. edt$k_open_in_out) then
X
X`09`09`09continue`09`09`09`09! error
X
X`09`09else if (code .eq. edt$k_put) then
X
X`09`09`09continue`09`09`09`09! error
X
X`09`09else if (code .eq. edt$k_close_del) then
X
X`09`09`09continue`09`09`09`09! no action
X
X`09`09else if (code .eq. edt$k_close) then
X
X`09`09`09continue`09`09`09`09! no action
X
X`09`09endif
X
X`09else if (stream .eq. edt$k_output_file) then
XC+++
XC Handle case of output file. Legal actions are open_output_noseq,
XC put, and close.  Close is used to reset the length to the
XC length of the file. Open resets pointers, and put is used to
XC write the data out. All other possible codes are checked for,
XC but none are handled.
XC---
X`09`09if (code .eq. edt$k_put) then
X
X`09`09`09if (out_ptr .le. max_col) then
X`09`09`09`09call str$copy_dx ( data(1,out_ptr), record )
X`09`09`09`09out_ptr = out_ptr+1
X`09`09`09endif
X
X`09`09else if (code .eq. edt$k_open_output_noseq) then
X
X`09`09`09length=0
X`09`09`09out_ptr=1
X
X`09`09else if (code .eq. edt$k_close) then
X
X`09`09`09length=out_ptr-1
X
X`09`09else if (code .eq. edt$k_get) then
X
X`09`09`09continue`09`09`09! error
X
X`09`09else if (code .eq. edt$k_open_input) then
X
X`09`09`09continue`09`09`09! error
X
X`09`09else if (code .eq. edt$k_open_output_seq) then
X
X`09`09`09continue`09`09`09! error
X
X`09`09else if (code .eq. edt$k_open_in_out) then
X
X`09`09`09continue`09`09`09! error
X
X`09`09else if (code .eq. edt$k_put) then
X
X`09`09`09continue`09`09`09! error
X
X`09`09else if (code .eq. edt$k_close_del) then
X
X`09`09`09continue`09`09`09! no action
X
X`09`09endif
X
X`09else if (stream .eq. edt$k_write_file) then
X
Xc`09`09Allow if operator, otherwise ignore.
X`09`09if(sysop2) afileio = edt$fileio(code,stream,record,rhb)
X
X`09else if (stream .eq. edt$k_command_file) then
X
X`09`09afileio = edt$fileio(code,stream,record,rhb)
X
X`09else if (stream .eq. edt$k_include_file) then
X
X`09`09if(sysop2) then
X`09`09`09afileio = edt$fileio(code,stream,record,rhb)
X`09`09else if (code .eq. edt$k_get) then
X`09`09`09afileio = RMS$_EOF
X`09`09`09end if
X
X`09else if (stream .eq. edt$k_journal_file) then
X
X`09`09afileio = edt$fileio(code,stream,record,rhb)
X
X`09endif
X
X`09return
X
X`09end
X`0C
X`09integer function netmail(
X`091   node,`09`09`09! Node to send to
X`092   from_name,`09`09`09! FROM name
X`093   to_name,`09`09`09! TO name @ node
X`094   to_show,`09`09`09! What to show in TO field
X`095   subject,`09`09`09! Subject
X`096   text)`09`09`09! Text array
Xcccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
Vcccc
Xc
Xc`09NETMAIL.FOR
Xc`09This program will send a message to a user using the VAX/VMS
Xc`09"handle" via DECnet.  Based on a BASIC program from "VAX Professional"
Xc
Xc`09Dale Miller - UALR
Xc
Xc`09Rev. 1.0  26-Jan-1987
Xcccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
Vcccc
X
X
X`09implicit none`20
X`20
X`09character*(*)  node
X`09character*(*) from_name
X`09character*(*) to_name
X`09character*(*) to_show
X`09character*(*) subject
X`09character*80 text(20)
X`09character*80 work
X
X`09integer istat,len,mlen,i
X`09integer str$trim,str$upcase
X
X`09logical errchk
X
X 1001`09format(a)
X
X
Xc`09Open the link to the mail task, and handle errors
X
X`09istat=str$upcase(work,node)
X`09istat=str$trim(work,work(1:6),len)
X
X`09open(unit=11,`09`09`09`09! Open channel to MAIL server
X`091   file=work(1:len)//'::"27="',
X`092   access='sequential',
X`093   form='formatted',
X`094   carriagecontrol='none',
X`095   status='new')
X
Xc`09Send the FROM information
X
X`09istat=str$trim(from_name,from_name,len)
X`09write(11,1001,err=9999) from_name(1:len)
Xc`09Send each message which states who should receive the text on the
Xc`09other side. ALWAYS CHECK what status the MAIL server gives back.
X
X`09istat=str$upcase(work,to_name)
X`09istat=str$trim(work,work(1:32),len)
X`09write(11,1001,err=9999)work(1:len)
X
X`09if (errchk(0)) go to 9999`09`09! Check if MAIL server accepted
Xc`09Terminate the list of receivers with a one byte null record
X
X`09write(11,1001,err=9999) char(0)
Xc`09Send the text that shows up in the TO: field of mail
X
X`09istat=str$trim(work,to_show,len)
X`09write(11,1001,err=9999) work(1:len)
Xc`09Write the subject line to the DECnet link.
X
X`09istat=str$trim(work,subject,len)
X`09write(11,1001,err=9999) work(1:len)`09! Put the text
Xc`09Read in each line of text and send it across line by line.
Xc`09This can be optimized to send one long chunk.
X
X`09mlen=20
X`09do while (text(mlen).eq.' ')
X`09    mlen=mlen-1
X`09    end do
X`09do i=1,mlen
X`09    istat=str$trim(work,text(i),len)
X`09    write(11,1001,err=9999) work(1:len)`09! Put the text
X`09    end do`20
X
Xc`09Write end of text message.
X
X`09write(11,1001,err=9999) char(0)`09`09! Put null byte
Xc`09Loop through and receive the status code for all users
Xc`09the mail was sent to.
X
X`09if(errchk(0)) go to 9999`09`09! Go check error, print msgs
Xc`09Finished, go close up shop
X
X`09close(unit=11)
X`09netmail=0
X`09return
X
X 9999`09Continue`09`09`09`09! Error return
X`09close(unit=11)
X`09netmail=1
X`09return
X`09end
X`0C`20
X`09logical function errchk(x)
Xc`09Check to see if the message just sent was received ok; or, check
Xc`09what the incoming message from the MAIL server says.
Xc`09This routine will dump error text to the terminal
X`09implicit none
X`09character*255 mess
X`09integer len
X`09integer x,dummy
X
X 1002`09format(q,a)
X`09read(11,1002,err=2000)len,mess
X`09dummy=ichar(mess(1:1))
X`09if((dummy.and.1).eq.1) then`09`09! Success?
X`09    errchk=.false.
X`09    return
X`09    end if
X
Xc`09Come here if an error was received
X
X
X 0020`09continue
X`09read(11,1002,err=2000)len,mess(1:len)`09! Get text/terminator indication
X
X`09if(len.ne.1) then`09`09`09! If len <> 1, must be text
X`09    print*,mess(1:len)`09`09`09! so print it
X`09    go to 0020`09`09`09`09! and loop for possibly more
X`09    end if
X`09if(ichar(mess(1:1)).ne.0) go to 20`09! 0 byte means all done
X`09errchk=.true.
X`09return
X
X 2000`09print*,'%Network communications error'
X`09errchk=.true.
X`09end
X`0C
X`09subroutine get_password (password,len)
Xcccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
Vcccc
Xc
Xc`09UBBS subroutines
Xc`09This routine will read a password and echo asterisks in its place.
Xc`09Dale Miller - UALR
Xc
Xc
Xc`09Rev. 3.5  19-Jun-1986
Xc`09Rev. 4.9  10-Feb-1987
Xc`09Rev. 5.3  02-Dec-1987
Xc`09Rev. 5.4  21-Dec-1987
Xc
Xcccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
Vcccc
X`09implicit none
X`09include 'bbs_inc.for/nolist'
X`09logical*1 asterisk(1)/'*'/
X`09logical*1 back_up(3)/bs,' ',bs/
X`09character password*(*)
X`09integer len,tempi,j,read_byte
X
X`09len=0
X`09timeouts=0
X`09password=' '
X
X 0010`09tempi=read_byte(60)
X`09if(timeouts.gt.4) call finish_timeout
X`09if(tempi.eq.cr) then`09`09`09`09!carriage return
X`09    do j=len+1,10
X`09`09call send_byte(asterisk)
X`09`09end do
X`09    call send_byte(cr)
X`09    return
X`09else if(tempi.eq.bs.or.tempi.eq.rub) then`09!Backspace or rubout
X`09    if(len.eq.0) go to 10`09`09`09!nothing to delete
X`09    password(len:len)=' '
X`09    len=len-1
X`09    call raw_write(back_up,3)
X`09else if(tempi.eq.nak.or.tempi.eq.can) then`09!`5EU or `5EX
X`09    do j=1,len
X`09`09call raw_write(back_up,3)
X`09`09end do
X`09    len=0
X`09    password=' '
X`09else if(len.ge.10) then
X`09    go to 10
X`09else if(tempi.le.us) then`09`09`09!other control character
X`09    go to 10
X`09else if(tempi.ge.97.and.tempi.le.122) then
X`09    tempi=tempi-32
X`09    len=len+1
X`09    password(len:len)=char(tempi)
X`09    call send_byte(asterisk)
X`09else
X`09    len=len+1
X`09    password(len:len)=char(tempi)
X`09    call send_byte(asterisk)
X`09end if
X
X`09go to 10
X
X`09end
X`0C
X`09subroutine get_upcase_string (string,len)
Xcccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
Vcccc
Xc
Xc`09UBBS subroutines
Xc`09This routine will allow input of an upper-case-only string.
Xc`09Dale Miller - UALR
Xc
Xc
Xc`09Rev. 3.5  19-Jun-1986
Xc`09Rev. 4.9  10-Feb-1987
Xc`09Rev. 5.3  02-Dec-1987
Xc`09Rev. 5.4  21-Dec-1987
Xc
Xcccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
Vcccc
X`09implicit none
X`09include 'bbs_inc.for/nolist'
X`09character string*(*)
X`09logical*1 back_up(3)/bs,' ',bs/
X`09logical*1 to_send(1)
X`09logical*1 spc
X`09integer tempi,len,max,j
X`09integer read_byte
X
X`09spc=.false.
X`09if(len.lt.0) then
X`09    len=-len
X`09    spc=.true.
X`09    end if
X`09max=len
X`09len=0
X`09timeouts=0
X`09string=' '
X
X 0010`09tempi=read_byte(60)
X`09if(timeouts.gt.4) then
X`09    call finish_timeout
X`09else if(tempi.eq.cr) then`09`09`09!carriage return
X`09    call send_byte(cr)
X`09    return
X`09else if(tempi.eq.bs .or. tempi.eq.rub) then`09!backspace or rub
X`09    if(len.eq.0) go to 10`09`09`09!nothing to delete
X`09    string(len:len)=' '
X`09    len=len-1
X`09    call raw_write(back_up,3)
X`09else if(tempi.eq.dc2) then`09`09`09!Control-r  (Repaint line)
X`09    call out(string(1:len),*10)
X`09else if(tempi.eq.nak.or.tempi.eq.can) then`09!`5EU or `5EX
X`09    do j=1,len
X`09`09call raw_write(back_up,3)
X`09`09end do
X`09    len=0
X`09    string=' '
X`09else if(len.ge.max) then
X`09    continue
X`09else if(tempi.le.us) then`09`09`09!other control character
X`09    continue
X`09else if(tempi.eq.32.and..not.spc) then
X`09    continue
X
Xc`09force to only alphabetic plus ' and -
X`09else if ((tempi.ge.33.and.tempi.le.38) .or.
X`091   (tempi.ge.40.and.tempi.le.44) .or.
X`092   (tempi.ge.46.and.tempi.le.64) .or.
X`093   (tempi.ge.91.and.tempi.le.96) .or.
X`094   (tempi.ge.123.and.tempi.le.126)) then
X`09    continue
X
Xc`09good character
X`09else
X`09    len=len+1
X`09    if(tempi.ge.97.and.tempi.le.122) tempi=tempi-32
X`09    string(len:len)=char(tempi)
X`09    to_send(1)=tempi
X`09    call send_byte(to_send)
X`09end if
X
X`09go to 10
X
X`09end
X`0C
X`09subroutine get_uplow_string (string,len)
Xcccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
Vcccc
Xc
Xc`09UBBS subroutines
Xc`09This routine will allow input of all but control characters.
Xc`09Dale Miller - UALR
Xc
Xc
Xc`09Rev. 3.5  19-Jun-1986
Xc`09Rev. 4.9  10-Feb-1987
Xc`09Rev. 5.3  02-Dec-1987
Xc`09Rev. 5.4  21-Dec-1987
Xc
Xcccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
Vcccc
X`09implicit none
X`09include 'bbs_inc.for/nolist'
X`09character string*(*)
X`09logical*1 back_up(3)/bs,' ',bs/
X`09logical*1 to_send(1),ctlz
X`09integer read_byte,tempi,j,len,max
X
X`09ctlz=.false.`09`09!assume no control-z allowed
X`09if(len.lt.0) then
X`09    len=-len
X`09    ctlz=.true.
X`09    end if
X`09max=len
X`09len=0
X`09timeouts=0
X`09string=' '
X
X 0010`09tempi=read_byte(60)
X`09if(timeouts.gt.4) then
X`09    call finish_timeout
X`09else if(tempi.eq.cr) then`09`09`09!carriage return
X`09    call send_byte(cr)
X`09    return
X`09else if(tempi.eq.bs .or. tempi.eq.rub) then`09!backspace or rub
X`09    if(len.eq.0) go to 10`09`09`09!nothing to delete
X`09    string(len:len)=' '`09`09`09`09!Clear out old one
X`09    len=len-1
X`09    call raw_write(back_up,3)
X`09else if(tempi.eq.dc2) then`09`09`09!Control-r  (Repaint line)
X`09    call out(string(1:len),*10)
X`09else if(tempi.eq.nak.or.tempi.eq.can) then`09!`5EU or `5EX
X`09    do j=1,len
X`09`09call raw_write(back_up,3)
X`09`09end do
X`09    len=0
X`09    string=' '
X`09else if((tempi.eq.sub).and.(len.eq.0).and.ctlz) then !control-z (eof)
X`09    len=-1
X`09    string=' '
X`09    return
X`09else if((tempi.eq.etx).and.(len.eq.0).and.ctlz) then !control-c (abort)
X`09    len=-2
X`09    string=' '
X`09    return
X`09else if(len.ge.max) then
X`09    continue
X`09else if(tempi.le.us) then`09`09`09!other control character
X`09    continue
X
Xc`09good character
X`09else
X`09    len=len+1
X`09    string(len:len)=char(tempi)
X`09    to_send(1)=tempi
X`09    call send_byte(to_send)
X`09end if
X
X`09go to 10
X
X`09end
X`0C
X`09subroutine get_number (string,len,flag)
Xcccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
Vcccc
Xc
Xc`09UBBS subroutines
Xc`09This routine will read a numeric string or an asterisk.
Xc`09If flag = .true. an asterisk is allowed.
Xc
Xc`09Dale Miller - UALR
Xc
Xc
Xc`09Rev. 3.5  19-Jun-1986
Xc`09Rev. 4.9  10-Feb-1987
Xc`09Rev. 4.11 27-Nov-1987
Xc`09Rev. 5.4  21-Dec-1987
Xc
Xcccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
Vcccc
X`09implicit none
X`09include 'bbs_inc.for/nolist'
X`09logical*1 asterisk(1)/'*'/
X`09logical*1 back_up(3)/bs,' ',bs/
X`09character string*(*)
X`09logical flag
X`09logical*1 to_send(1)
X`09integer read_byte,tempi,j,len,max
X
X`09max=len`09`09`09`09
X`09len=0
X`09timeouts=0
X`09string=' '
X
X 0010`09tempi=read_byte(60)
X`09if(timeouts.gt.4) then
X`09    call finish_timeout
X`09else if(tempi.eq.cr) then`09`09`09!carriage return
X`09    call send_byte(cr)
X`09    return
X`09else if(tempi.eq.bs .or. tempi.eq.rub) then`09!backspace or rub
X`09    if(len.eq.0) go to 10`09`09`09!nothing to delete
X`09    string(len:len)=' '
X`09    len=len-1
X`09    call raw_write(back_up,3)
X`09else if(tempi.eq.dc2) then`09`09`09!Control-r  (Repaint line)
X`09    call out(string(1:len),*10)
X`09else if(tempi.eq.nak.or.tempi.eq.can) then`09!`5EU or `5EX
X`09    do j=1,len
X`09`09call raw_write(back_up,3)
X`09`09end do
X`09    len=0
X`09    string=' '
X`09else if(len.ge.max) then
X`09    continue
X`09else if(tempi.eq.42.and.(len.ne.0.or.(.not.flag))) then`09!Asterisk
X`09     continue
X`09else if(tempi.gt.42.and.tempi.lt.48) then`09!Non-numeric
X`09    continue
X`09else if(tempi.lt.42.or.tempi.gt.57) then`09!Non-numeric
X`09    continue
X`09else if(string(1:1).eq.'*') then`09`09!Asterisk was entered
X`09    continue
Xc`09good character
X`09else
X`09    len=len+1
X`09    string(len:len)=char(tempi)
X`09    to_send(1)=tempi
X`09    call send_byte(to_send)
X`09end if
X
X`09go to 10
X
X`09end
X`0C
X`09subroutine get_filnam_string (string,len)
Xcccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
Vcccc
Xc
Xc`09UBBS subroutines
Xc`09This routine will allow input of a VAX filename.
Xc
Xc`09Dale Miller - UALR
Xc
Xc
Xc`09Rev. 3.5  19-Jun-1986
Xc`09Rev. 4.9  10-Feb-1987
Xc`09Rev. 4.12 11-Jun-1987
Xc`09Rev. 5.4  21-Dec-1987
Xc
Xcccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
Vcccc
X`09implicit none
X`09include 'bbs_inc.for/nolist'
X`09character string*(*)
X`09logical*1 back_up(3)/bs,' ',bs/
X`09logical*1 to_send(1)
X`09logical*1 period
X`09integer read_byte,tempi,j,len,max
X
X`09period=.false.
X`09max=len
X`09len=0
X`09timeouts=0
X`09string=' '
X
X 0010`09tempi=read_byte(60)
X`09if(timeouts.gt.4) then
X`09    call finish_timeout
X`09else if(tempi.eq.cr) then`09`09`09!carriage return
X`09    call send_byte(cr)
X`09    if(period) then
X`09`09return
X`09    else
X`09`09if(len.eq.max) len=len-1
X`09`09len=len+1
X`09`09string(len:len)='.'
X`09`09return
X`09    end if
X`09else if(tempi.eq.bs .or. tempi.eq.rub) then`09!backspace or rub
X`09    if(len.eq.0) go to 10`09`09`09!nothing to delete
X`09    string(len:len)=' '
X`09    len=len-1
X`09    call raw_write(back_up,3)
X`09else if(tempi.eq.dc2) then`09`09`09!Control-r  (Repaint line)
X`09    call out(string(1:len),*10)
X`09else if(tempi.eq.nak.or.tempi.eq.can) then`09!`5EU or `5EX
X`09    do j=1,len
X`09`09call raw_write(back_up,3)
X`09`09end do
X`09    len=0
X`09    string=' '
X`09else if(len.ge.max) then
X`09    continue
X`09else if(tempi.le.us) then`09`09`09!other control character
X`09    continue
X
Xc`09force to only alphabetic plus _,$,- and .
X
X`09else if(tempi.eq.46.and.period) then
X`09    continue
X`09else if ((tempi.le.35) .or.
X`091   (tempi.eq.36.and.len.eq.0) .or.`09`09! Disallow leading $
X`092   (tempi.ge.37.and.tempi.le.44) .or.
X`093   (tempi.eq.47) .or.
X`094   (tempi.ge.58.and.tempi.le.64) .or.
X`095   (tempi.ge.91.and.tempi.le.94) .or.
X`096   (tempi.eq.96) .or.
X`097   (tempi.ge.123.and.tempi.le.126)) then
X`09    continue
X
Xc`09good character
X`09else
X`09    len=len+1
X`09    if(tempi.ge.97.and.tempi.le.122) tempi=tempi-32
X`09    string(len:len)=char(tempi)
X`09    to_send(1)=tempi
X`09    call send_byte(to_send)
X`09    if(tempi.eq.46) period=.true.
X`09end if
X
X`09go to 10
X
X`09end
X`0C
X`09subroutine searchcat(darea)
Xcccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
Vcccc
Xc
Xc`09UBBS subroutines
Xc`09This routine will search the directory of files for a download area
Xc`09for a specific keyword.
Xc`09Dale Miller - UALR
Xc
Xc
Xc`09Rev. 4.10 11-Feb-1987
Xc`09Rev. 6.0  06-Jun-1988
Xc`09Rev. 7.2  02-Jan-1989
Xc
Xcccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
Vcccc
X`09implicit none
X`09include 'bbs_inc.for'
X`09character*(*) darea
X`09character cdate*11,filtyp*6,startoff*18
X`09character keyword*40,lookup*40
X`09integer length,dummy,kl
X`09real*8 long_ago
X`09logical short
X
X`09integer istat,keyln
X`09integer compquad
X`09integer sys$asctim,sys$bintim,str$upcase,str$trim
X`09external uopen
X
X`09record/file_description/ fd
X
X`09write(6,1001)crlf(:cl)//'Keyword to search for? `5Bexit`5D'
X`09kl=40
X`09call get_uplow_string(keyword,kl)
X`09if(kl.eq.0) return
X`09istat=str$upcase(keyword,keyword)
X
X`09short=.true.
X`09write(6,1001)crlf(:cl)//'Do you want a short or a long listing?'//
X`091   ' `5BShort`5D'
X`09dummy=5
X`09call get_upcase_string(startoff,dummy)
X`09if(startoff(1:1).eq.'L') short=.false.
X`09write(6,1001)crlf(:cl)//'Enter earliest date of files you'//
X`091   ' wish to see.'//crlf(:cl)//
X`092   'The date must be dd-mmm-yyyy (e.g. 19-APR-1986)'//
X`093   crlf(:cl)//'Or enter <cr> for a all dates.'//
X`094   crlf(:cl)//'?'
X`09dummy=11
X`09call get_uplow_string(cdate,dummy)
X`09if(dummy.eq.0) cdate='01-JUL-1985'
X`09istat=str$upcase(cdate,cdate)
X`09istat = sys$bintim(cdate(:11)//' 00:00:00.00',long_ago)
X`09istat = sys$asctim(,cdate,long_ago,)
X
X`09write(6,1001)crlf(:cl)//
X`091   'Enter the starting file name or <cr> for beginning :'
X`09dummy=18
X`09startoff=char(0)
X`09call get_filnam_string(startoff,dummy)
X`09if(startoff.eq.' ') startoff='.'
X`09cdate(5:5)=char(ichar(cdate(5:5))+32)
X`09cdate(6:6)=char(ichar(cdate(6:6))+32)
X`09write(6,1001)crlf(:cl)//'    Files since: '//cdate(:11)
X`09call ctrl_o_check(*10,*10)
X
Xc`09Open the indexed file for reading.
X`09open(unit=4,`09`09shared,
X`091   file='ubbs_files:`5B'//darea//'`5Dfiles.idx',
X`092   status='old',`09organization='indexed',
X`093   access='keyed',`09form='unformatted',
X`094   recl=192,`09`09recordtype='variable',
X`095   readonly,`09`09key=(1:18:character),
X`096   useropen=uopen)
X
X`09fd.file_name='$Header'
X`09read(4,key=fd.file_name,err=100)fd
X`09istat = sys$asctim(,cdate,fd.upload_date,)
X
X`09cdate(5:5)=char(ichar(cdate(5:5))+32)
X`09cdate(6:6)=char(ichar(cdate(6:6))+32)
X`09write(6,1001)crlf(:cl)//'Last file added: '//cdate(:11)
X`09call ctrl_o_check(*10,*10)
X
X 0100`09fd.file_name=startoff
X`09read(4,keygt=fd.file_name,iostat=ios)fd
X`09do while (ios.eq.0)
X
X`09    call ctrl_o_check(*10,*10)
X
X`09    istat=str$upcase(lookup,fd.keywords)
X`09    if(index(fd.file_name//' '//lookup,keyword(1:kl)).eq.0) go to 110
X
X`09    if(fd.file_type.eq.'A') then
X`09`09filtyp='Ascii '
X`09    else if(fd.file_type.eq.'B') then
X`09`09filtyp='Binary'
X`09    else
X`09`09go to 110
X`09    end if
X`09    istat=compquad(fd.upload_date,long_ago)
X`09    if(istat.ne.-1 .and. (.not.short)) then
X`09`09write(6,1001)crlf(:cl)//
X`091`09    '************************************************'//
X`092`09    '***********************'//crlf(:cl)
X`09`09istat = sys$asctim(,cdate,fd.upload_date,)
X`09`09cdate(5:5)=char(ichar(cdate(5:5))+32)
X`09`09cdate(6:6)=char(ichar(cdate(6:6))+32)
X`09`09istat=str$trim(fd.keywords,fd.keywords,keyln)
X
X`09    `09write(6,1002)crlf(:cl),fd.file_name,cdate(:11),
X`091`09    (fd.file_size+1)/2,filtyp,fd.times_down,
X`092`09    crlf(:cl)//crlf(:cl),
X`093`09    fd.keywords(:keyln),fd.upload_name//crlf(:cl)
X
X`09`09istat=index(fd.upload_text,char(cr))
X`09`09do while(istat.ne.0)
X`09`09    write(6,1001)crlf(:cl)//fd.upload_text(:istat-1)
X`09`09    call ctrl_o_check(*10,*10)
X`09`09    fd.upload_text=fd.upload_text(istat+1:)
X`09`09    istat=index(fd.upload_text,char(cr))
X`09`09    end do
X`09        end if
X`09    if(istat.ne.-1 .and. short) then
X`09`09istat = sys$asctim(,cdate,fd.upload_date,)
X`09`09cdate(5:5)=char(ichar(cdate(5:5))+32)
X`09`09cdate(6:6)=char(ichar(cdate(6:6))+32)
X`09`09istat=str$trim(fd.keywords,fd.keywords,keyln)
X
X`09    `09write(6,1003)crlf(:cl),fd.file_name,cdate(:11),
X`091`09    (fd.file_size+1)/2,filtyp,fd.keywords(:keyln)
X
X`09        end if
X 0110`09    read(4,keygt=fd.file_name,iostat=ios)fd
X`09    end do
X 0010`09close(unit=4)
X`09return
X 1001`09format(a)
X 1002`09format(a,a18,5x,a11,1x,i5,'K bytes',2x,a6,4x,'Accesses:',i5,a,5x,
X`091   'Keywords: ',a,' By:',a)
X 1003`09format(a,a18,1x,a11,i4,'K ',a6,1x,a)
X`09end
X`0C
X`09subroutine send_code
X
Xc`09These routines are used to send a control character to the remote.
X
X`09implicit none
X`09include 'bbs_inc.for/nolist'
X`09logical*1 last_code(2)
X
Xc`09Entry to send line feed
X
X`09entry send_lf
X`09last_code(1) = lf
X`09go to 100
X
Xc`09Entry to send carriage return
X
X`09entry send_cr
X`09last_code(1) = cr
X`09go to 100
X
Xc`09Entry to send SOH (Start of Header).`09CTRL/A
X
X`09entry send_soh
X`09last_code(1) = soh
X`09go to 100
X
Xc`09Entry to send STX (Start of Text).`09CTRL/B
X
X`09entry send_stx
X`09last_code(1) = stx
X`09go to 100
X
Xc`09Entry to send ETX (End of Text).`09CTRL/C
X
X`09entry send_etx
X`09last_code(1) = etx
X`09go to 100
X
Xc`09Entry to send ACK (Acknowlegment).
X
X`09entry send_ack
X`09last_code(1) = ack
X`09go to 100
X
Xc`09Entry to send NAK (Negative Acknowlement).
X
X`09entry send_nak
X`09last_code(1) = nak
X`09go to 100
X
Xc`09Entry to send SYN (Synchronize).
X
X`09entry send_syn
X`09last_code(1) = syn
X`09go to 100
X
Xc`09Entry to send ENQ (Enquire).
X
X`09entry send_enq
X`09last_code(1) = enq
X`09go to 100
X
Xc`09Entry to send EOF (End of File).
X
X`09entry send_eof
X`09last_code(1) = sub
X`09go to 100
X
Xc`09Entry to send EOT (End of Transmission).
X
X`09entry send_eot
X`09last_code(1) = eot
X`09go to 100
X
Xc`09Entry to send CAN (Cancel).
X
X`09entry send_can
X`09last_code(1) = can
X`09go to 100
X
Xc`09Entry to send 'C' (CRC sync character).
X
X`09entry send_c
X`09last_code(1) = '43'X
X`09go to 100
XC
XC`09This entry is used to resend the last code in the event that
XC`09the previous transmission was lost or garbled and the remote
XC`09sent us an ENQ to find out what the last response was.
XC
X`09entry resend_code
X100`09call raw_write (last_code(1), 1)
X`09return
X`09end
X`0C
X`09logical function get_xmodem
Xcccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
Vcccc
Xc
Xc`09UBBS subroutines - GET_XMODEM.FOR
Xc`09This routine is used transfer a file from the remote system to
Xc`09the VAX using the XMODEM protocol.
Xc`09Dale Miller - UALR
Xc
Xc`09Rev. 4.13 04-Jul-1987
Xc`09Rev. 5.6  03-Mar-1988
Xc`09Rev. 6.2  21-Jul-1988
+-+-+-+-+-+-+-+-  END  OF PART 6 +-+-+-+-+-+-+-+-