home *** CD-ROM | disk | FTP | other *** search
/ NetNews Usenet Archive 1992 #18 / NN_1992_18.iso / spool / vmsnet / sources / 310 < prev    next >
Encoding:
Internet Message Format  |  1992-08-21  |  47.0 KB
  1. Path: sparky!uunet!zaphod.mps.ohio-state.edu!news.acns.nwu.edu!network.ucsd.edu!mvb.saic.com!vmsnet-sources
  2. From: munroe@dmc.com (Dick Munroe)
  3. Newsgroups: vmsnet.sources
  4. Subject: UBBS, part 08/12
  5. Message-ID: <7868493@MVB.SAIC.COM>
  6. Date: Fri, 21 Aug 1992 20:21:31 GMT
  7. Organization: Doyle, Munroe Consultants, Inc., Hudson, MA
  8. Lines: 1482
  9. Approved: Mark.Berryman@Mvb.Saic.Com
  10.  
  11. Submitted-by: munroe@dmc.com (Dick Munroe)
  12. Posting-number: Volume 3, Issue 116
  13. Archive-name: ubbs/part08
  14. -+-+-+-+-+-+-+-+ START OF PART 8 -+-+-+-+-+-+-+-+
  15. X`09KERMIT_OPENR = .TRUE.`09`09`09! Show file is open.
  16. X`09RETURN
  17. X
  18. X9900`09CALL RMS_ERROR (MODULE_NAME)`09`09! Report the RMS error.
  19. X`09KERMIT_OPENR = .FALSE.`09`09`09! Show file open failed.
  20. X`09RETURN
  21. X`09END
  22. X`0C
  23. X`09LOGICAL FUNCTION KERMIT_PACK (FBUFF, P_DATA, P_LEN)
  24. XC
  25. XC`09This function is used to pack the data a VAX file into a data
  26. XC`09packet for transmission to the remote KERMIT.
  27. XC
  28. XC`09Inputs:
  29. XC`09`09FBUFF`09The input file buffer.`09`09`09(By Descriptor)
  30. XC`09`09P_DATA`09The data packet buffer.`09`09`09(By Reference)
  31. XC`09`09P_LEN`09The packet data length.`09`09`09(By Reference)
  32. XC`09`09RBYTES`09The current record count.`09`09(Global)
  33. XC
  34. XC`09Outputs:
  35. XC`09`09Returns .TRUE./.FALSE. = Success/Failure.
  36. XC
  37. X`09IMPLICIT NONE
  38. X`09INCLUDE 'kermit_inc.for'
  39. X`09INCLUDE 'bbs_inc.for'
  40. X
  41. X`09LOGICAL`09KERMIT_READ
  42. X`09CHARACTER*(*) FBUFF
  43. X`09BYTE`09P_DATA (MAXDATASIZ)
  44. X`09BYTE`09P_LEN
  45. X
  46. X`09BYTE`09C`09`09`09`09! The next file character.
  47. X`09BYTE`09C7`09`09`09`09! 7-bit version of above.
  48. X`09INTEGER F,`09`09`09`09! Index into file buffer.
  49. X`091`09I`09`09`09`09! Index into packet data.
  50. X
  51. X`09IF (END_OF_FILE) THEN`09`09`09! If at end of file,
  52. X`09    KERMIT_PACK = .FALSE.`09`09!   then return failure.
  53. X`09    RETURN
  54. X`09ENDIF
  55. XC
  56. XC`09Pack the file data into the data packet.
  57. XC
  58. X`09I = 1`09`09`09`09`09! Initialize packet index.
  59. X`09P_LEN = 0`09`09`09`09! Initialize packet length.
  60. X`09DO WHILE (I .LT. PACKET_LENGTH)`09`09! Do until packet limit.
  61. X`09    IF (RBYTES .EQ. 0) THEN`09`09! More bytes is the buffer?
  62. X`09`09F = 1`09`09`09`09! Initialize file buffer index.
  63. X`09`09IF (.NOT. KERMIT_READ (FBUFF, RBYTES)) THEN
  64. X`09`09    IF (P_LEN .NE. 0) THEN`09! Have a partial packet ?
  65. X`09`09`09KERMIT_PACK = .TRUE.`09! Yes, send this packet.
  66. X`09`09`09RETURN
  67. X`09`09    ELSE
  68. X`09`09`09KERMIT_PACK = .FALSE.`09! Else, show file is done.
  69. X`09`09`09RETURN
  70. X`09`09    ENDIF
  71. X`09`09ENDIF
  72. X`09    ENDIF
  73. X`09    C = ICHAR (FBUFF(F:F))`09`09! Copy the next character.
  74. X`09    C7 = C .AND. "177`09`09`09! 7-bit version of above.
  75. X`09    IF ( (C7 .LT. SP) .OR. (C7 .EQ. RUB)
  76. X`091`09`09`09.OR. (C7 .EQ. QCTLC) ) THEN
  77. X`09`09IF (I+1 .GE. PACKET_LENGTH) THEN ! Too close to packet end?
  78. X`09`09    KERMIT_PACK = .TRUE.`09! Yes, show packet ready.
  79. X`09`09    RETURN
  80. X`09`09ENDIF
  81. X`09`09P_DATA(I) = QCTLC`09`09! Must quote this character.
  82. X`09`09I = I + 1`09`09`09! Adjust the packet index.
  83. X`09`09IF (C7 .EQ. QCTLC) THEN`09`09! If quote character,
  84. X`09`09    P_DATA(I) = C`09`09!   copy the quote char.
  85. X`09`09ELSE
  86. X`09`09    P_DATA(I) = (C .XOR. 64)`09! Uncontolify the character.
  87. X`09`09ENDIF
  88. X`09`09I = I + 1`09`09`09! Point to next position.
  89. X`09`09P_LEN = P_LEN + 2`09`09! Adjust the packet length.
  90. X`09    ELSE
  91. X`09`09P_DATA(I) = C`09`09`09! Copy normal character.
  92. X`09`09I = I + 1`09`09`09! Point to next position.
  93. X`09`09P_LEN = P_LEN + 1`09`09! Adjust the packet length.
  94. X`09    ENDIF
  95. X`09    F = F + 1`09`09`09`09! Adjust file buffer index.
  96. X`09    RBYTES = RBYTES - 1`09`09`09! Adjust the record bytes.
  97. X`09ENDDO
  98. X`09KERMIT_PACK = .TRUE.`09`09`09! Yes, show packet ready.
  99. X`09RETURN
  100. X`09END
  101. X`0C
  102. X`09LOGICAL FUNCTION KERMIT_READ (FDATA, BYTES)
  103. XC
  104. XC`09This function used to read a record from the VAX file.
  105. XC
  106. XC`09Inputs:
  107. XC`09`09FDATA`09The file read buffer.
  108. XC`09`09BYTES`09Variable for bytes read.
  109. XC
  110. XC`09Outputs:
  111. XC`09`09BYTES`09The number of bytes read.
  112. XC
  113. XC`09`09Returns .TRUE./.FALSE. = Success/Failure.
  114. XC
  115. X`09IMPLICIT NONE
  116. X`09INCLUDE 'kermit_inc.for'
  117. X`09INCLUDE 'bbs_inc.for'
  118. X
  119. X`09INTEGER BYTES
  120. X`09CHARACTER*(*) FDATA, MODULE_NAME
  121. X`09PARAMETER (MODULE_NAME = 'KERMIT_READ')
  122. XC
  123. XC`09Read a record from the VAX file.
  124. XC
  125. X`09BYTES = 0`09`09`09`09! Initialize byte count.
  126. X`09DO WHILE (BYTES .EQ. 0)
  127. X`09    READ (FILE_UNIT, 100, END=9910, ERR=9900) BYTES, FDATA
  128. X100`09    FORMAT (Q, A)
  129. X`09    CALL KERMIT_TOTALS (BYTES)`09`09! Update the file totals.
  130. X`09    IF (FILE_TYPE.NE.BINARY) THEN`09`09! If ASCII file type,
  131. X`09`09BYTES = BYTES + 1`09`09! Count carriage return.
  132. X`09`09FDATA(BYTES:BYTES) = CHAR(CR)`09! Append carriage return.
  133. X`09`09BYTES = BYTES + 1`09`09! Count the line feed.
  134. X`09`09FDATA(BYTES:BYTES) = CHAR(LF)`09! Append the line feed.
  135. X`09    ENDIF
  136. X`09ENDDO
  137. X`09KERMIT_READ = .TRUE.`09`09`09! Show read successful.
  138. X`09RETURN
  139. XC
  140. XC`09We come here when an error occurs reading the input file.
  141. XC
  142. X9900`09CALL RMS_ERROR (MODULE_NAME)`09`09! Report the RMS error.
  143. XC
  144. XC`09We come here for end of file on input file.
  145. XC
  146. X9910`09CLOSE (UNIT=FILE_UNIT)`09`09`09! Close the input file.
  147. X`09END_OF_FILE = .TRUE.`09`09`09! Show EOF or error.
  148. X`09KERMIT_READ = .FALSE.`09`09`09! Show the read failed.
  149. X`09RETURN
  150. X`09END
  151. X`0C
  152. X`09SUBROUTINE KERMIT_TOTALS (BYTES)
  153. XC
  154. XC`09This routine is called after a record is successfully transmitted
  155. XC`09to update the various counters.  Since the routine is called while
  156. XC`09building a transmit packet from multiple input records, the record
  157. XC`09display has a special entry which is called after transmitting the
  158. XC`09current block.
  159. XC
  160. XC`09Inputs:
  161. XC`09`09BYTES`09The number of record bytes.
  162. XC
  163. X`09IMPLICIT NONE
  164. X`09INCLUDE 'kermit_inc.for'
  165. X`09INCLUDE 'BBS_INC.FOR'
  166. X
  167. X`09INTEGER BYTES
  168. X
  169. X`09BYTE_COUNT = BYTE_COUNT + BYTES`09`09! Accumulate the byte count
  170. X`09RECORD_COUNT = RECORD_COUNT + 1`09`09!`09and the record count.
  171. X`09TOTAL_BYTES = TOTAL_BYTES + BYTES`09! Update the total byte count.
  172. X`09TOTAL_RECORDS = TOTAL_RECORDS + 1`09!`09and the record count.
  173. X`09RETURN
  174. X
  175. X`09ENTRY KERMIT_REPORT
  176. X`09RETRY_COUNT = 0`09`09`09`09! Reinitialize retry counter.
  177. X`09RETURN
  178. X`09END
  179. X`0C
  180. X`09LOGICAL FUNCTION KERMIT_UNPACK (FBUFF, P_DATA, P_LEN)
  181. XC
  182. XC`09This function is used to unpack a data packet and write the data
  183. XC`09to the the VAX file.
  184. XC
  185. XC`09Inputs:
  186. XC`09`09FBUFF`09The output file buffer.`09`09`09(By Descriptor)
  187. XC`09`09P_DATA`09The data packet buffer.`09`09`09(By Reference)
  188. XC`09`09P_LEN`09The packet data length.`09`09`09(By Reference)
  189. XC`09`09RBYTES`09The current record count.`09`09(Global)
  190. XC
  191. XC`09Outputs:
  192. XC`09`09Returns .TRUE./.FALSE. = Success/Failure.
  193. XC
  194. X`09IMPLICIT NONE
  195. X`09INCLUDE 'kermit_inc.for'
  196. X`09INCLUDE 'bbs_inc.for'
  197. X
  198. X`09LOGICAL`09KERMIT_WRITE
  199. X`09CHARACTER*(*) FBUFF
  200. X`09BYTE`09P_DATA (MAXDATASIZ)
  201. X`09BYTE`09P_LEN
  202. X
  203. X`09LOGICAL QUOTE_SEEN`09`09`09! Control quote seen flag.
  204. X`09INTEGER F,`09`09`09`09! Index into file buffer.
  205. X`091`09I`09`09`09`09! Index into packet data.
  206. XC
  207. XC`09Copy and decode the data packet.
  208. XC
  209. X`09F = RBYTES`09`09`09`09! Copy record byte count.
  210. X`09QUOTE_SEEN = .FALSE.`09`09`09! Init the quote seen flag.
  211. X`09DO I = 1, P_LEN
  212. X`09  IF (QUOTE_SEEN) THEN
  213. X`09    IF ((P_DATA(I) .AND. "177) .NE. QCTLC) THEN ! Quote of quote?
  214. X`09      FBUFF(F:F) = CHAR(P_DATA(I) .XOR. 64) ! No convert control.
  215. X`09    ELSE
  216. X`09      FBUFF(F:F) = CHAR(P_DATA(I))`09! Copy the quote char.
  217. X`09    ENDIF
  218. X`09    QUOTE_SEEN = .FALSE.`09`09! Re-init quote flag.
  219. XC
  220. XC`09Check for carriage-return/line-feed sequence for record end.
  221. XC
  222. X`09    IF ( (FILE_TYPE.NE.BINARY) .AND. (F .GT. 1) ) THEN
  223. X`09      IF ( (FBUFF(F-1:F-1) .EQ. CHAR(CR)) .AND.
  224. X`091`09`09FBUFF(F:F) .EQ. CHAR(LF) ) THEN
  225. X`09`09KERMIT_UNPACK = KERMIT_WRITE (FBUFF(1:F-2))
  226. X`09`09F = 0`09`09`09`09! Reset buffer index.
  227. X`09`09IF (.NOT. KERMIT_UNPACK) RETURN`09! Return failure status.
  228. X`09      ENDIF
  229. X`09    ELSEIF (F .EQ. 128) THEN
  230. X`09      KERMIT_UNPACK = KERMIT_WRITE (FBUFF(1:F))
  231. X`09      F = 0`09`09`09`09! Reset buffer index.
  232. X`09      IF (.NOT. KERMIT_UNPACK) RETURN`09! Return failure status.
  233. X`09    ENDIF
  234. X`09  ELSE
  235. X`09    F = F + 1`09`09`09`09! Point to next position.
  236. X`09    FBUFF(F:F) = CHAR(P_DATA(I))`09! Copy the data character.
  237. X`09    IF (P_DATA(I) .EQ. QCTLC) THEN`09! If quote character,
  238. X`09      QUOTE_SEEN = .TRUE.`09`09!   show quote was seen.
  239. X`09    ELSEIF ( (FILE_TYPE.EQ.BINARY) .AND. (F .EQ. 128) ) THEN
  240. X`09      KERMIT_UNPACK = KERMIT_WRITE (FBUFF(1:F))
  241. X`09      F = 0`09`09`09`09! Reset buffer index.
  242. X`09      IF (.NOT. KERMIT_UNPACK) RETURN`09! Return failure status.
  243. X`09    ENDIF
  244. X`09  ENDIF
  245. X`09ENDDO
  246. X`09RBYTES = F`09`09`09`09! Copy the buffer index.
  247. X`09KERMIT_UNPACK = .TRUE.`09`09`09! Show data unpacked OK.
  248. X`09RETURN
  249. X`09END
  250. X`0C
  251. X`09LOGICAL FUNCTION KERMIT_WRITE (FDATA)
  252. XC
  253. XC`09This function used to KERMIT packet data to the VAX file.
  254. XC
  255. XC`09Inputs:
  256. XC`09`09FDATA`09The file data to write.
  257. XC
  258. XC`09Outputs:
  259. XC`09`09Returns .TRUE./.FALSE. = Success/Failure.
  260. XC
  261. X`09IMPLICIT NONE
  262. X`09INCLUDE 'kermit_inc.for'
  263. X`09INCLUDE 'bbs_inc.for'
  264. X
  265. X`09CHARACTER*(*) FDATA, MODULE_NAME
  266. X`09PARAMETER (MODULE_NAME = 'KERMIT_WRITE')
  267. XC
  268. XC`09Write the data to the output file.
  269. XC
  270. X`09WRITE (FILE_UNIT, 100, ERR=9900) FDATA
  271. X100`09FORMAT (A)
  272. X`09CALL KERMIT_TOTALS (LEN(FDATA))`09`09! Update file totals.
  273. X`09CALL KERMIT_REPORT()`09`09`09! Update the screen.
  274. X`09KERMIT_WRITE = .TRUE.`09`09`09! Show write successful.
  275. X`09RETURN
  276. X
  277. X9900`09CALL RMS_ERROR (MODULE_NAME)`09`09! Report the RMS error.
  278. X`09KERMIT_WRITE = .FALSE.`09`09`09! Show the write failed.
  279. X`09RETURN
  280. X`09END
  281. X`0C
  282. X`09INTEGER FUNCTION RECEIVE_PACKET (P_DATA, P_LEN, P_NUM)
  283. XC
  284. XC`09This function is used to receive a packet.
  285. XC
  286. XC`09Inputs:
  287. XC`09`09P_DATA`09Buffer for received data.
  288. XC`09`09P_LEN`09The data length.
  289. XC`09`09P_NUM`09The packet number.
  290. XC
  291. XC`09Outputs:
  292. XC`09`09The value returned is the packet type.
  293. XC
  294. XC`09`09The above inputs are filled on success.
  295. XC
  296. X`09IMPLICIT NONE
  297. X`09INCLUDE 'kermit_inc.for'
  298. X`09INCLUDE 'bbs_inc.for'
  299. X
  300. X`09BYTE`09P_DATA (MAXDATASIZ)
  301. X`09BYTE`09P_NUM, P_LEN
  302. X
  303. X`09INTEGER CHECKSUM, I, PCHK, PACK_SIZE, STATUS
  304. X`09INTEGER KERMIT_CHECKSUM, READ_BYTE, RAW_READ
  305. XC
  306. XC`09Packet Format:
  307. XC
  308. XC`09+------+-----------+-----------+------+--------------+-------+
  309. XC`09`7C MARK `7C char(LEN) `7C char(SEQ) `7C TYPE `7C ... DATA ... `7C CHECK
  310. V `7C
  311. XC`09+------+-----------+-----------+------+--------------+-------+
  312. XC`09       `7C<---- Packet Length / Check Calculation ---->`7C
  313. X
  314. XC
  315. XC`09Wait for the start of a packet character.
  316. XC
  317. X`09PACKET(PMARK) = 0`09`09`09! Initialize mark field.
  318. X`09DO WHILE (PACKET(PMARK) .NE. MARKC)`09! Loop until MARK detected.
  319. X`09    IF (CONTROLC_TYPED) THEN`09`09! CTRL/C typed to abort?
  320. X`09`09RECEIVE_PACKET = 'A'`09`09! Return an "Abort" code.
  321. X`09`09RETURN
  322. X`09    ENDIF
  323. X`09    PACKET(PMARK) = READ_BYTE (TIMOUT)`09! Read start of packet.
  324. X`09ENDDO
  325. XC
  326. XC`09Read the packet size.
  327. XC
  328. X`09PACKET(PLEN) = READ_BYTE (TIMOUT)`09! Read the packet size.
  329. X`09IF (PACKET(PLEN) .NE. 0) THEN
  330. X`09    PACK_SIZE = PACKET(PLEN) - 32`09! Copy the packet size.
  331. X`09    PACK_SIZE = PACK_SIZE .AND. "177`09! Make sure not too big.
  332. X`09    IF (PACK_SIZE .GT. PACKBUFSIZ) THEN
  333. X`09`09PACK_SIZE = PACKBUFSIZ`09`09! Set maximum packet size.
  334. X`09    ENDIF
  335. X`09ELSE
  336. X`09    RECEIVE_PACKET = .FALSE.`09`09! Timeout or error.
  337. X`09    RETURN
  338. X`09ENDIF
  339. XC
  340. XC`09Read the rest of the packet (+1 for end of line character).
  341. XC
  342. X`09STATUS = 0`09`09`09`09! Initialize status code.
  343. X`09DO WHILE (.NOT. STATUS)
  344. X`09    IF (CONTROLC_TYPED) THEN`09`09! CTRL/C typed to abort?
  345. X`09`09RECEIVE_PACKET = 'A'`09`09! Return an "Abort" code.
  346. X`09`09RETURN
  347. X`09    ENDIF
  348. X`09    STATUS = RAW_READ (PACKET(PSEQ), PACK_SIZE+1, TIMOUT, TPTR)
  349. X`09    IF (.NOT. STATUS) THEN
  350. X`09`09RECEIVE_PACKET = .FALSE.`09! Return failure status.
  351. X`09`09RETURN
  352. X`09    ENDIF
  353. X`09ENDDO
  354. XC
  355. XC`09Decode the packet and validate the checksum.
  356. XC
  357. X`09CHECKSUM = KERMIT_CHECKSUM (PACKET(PLEN), PACK_SIZE)
  358. X`09PCHK = (PACKET(PLEN) - 32) + TO_CHECK`09! Set offset to checksum.
  359. XC
  360. XC`09If the checksum matches return the received packet type, otherwise
  361. XC`09return failure.
  362. XC
  363. X`09IF ( CHECKSUM .EQ. (PACKET(PCHK)-32) ) THEN ! If checksum matches,
  364. X`09    P_LEN = PACKET(PLEN) - 32 - POVER`09! Copy the packet length.
  365. X`09    P_NUM = PACKET(PSEQ) - 32`09`09! Copy the packet number.
  366. X`09    DO I = 1, P_LEN
  367. X`09`09P_DATA(I) = PACKET(PDATA+(I-1))`09! Copy the packet data.
  368. X`09    ENDDO
  369. X`09    RECEIVE_PACKET = PACKET(PTYPE)`09! Return the packet type.
  370. X`09ELSE
  371. X`09    RECEIVE_PACKET = .FALSE.`09`09! Return failure status.
  372. X`09ENDIF
  373. X`09RETURN
  374. X`09END
  375. X`0C
  376. X`09INTEGER FUNCTION KSEND_PACKET (P_DATA, P_LEN, P_NUM, P_TYPE)
  377. XC
  378. XC`09This function is used to send a packet.
  379. XC
  380. XC`09Inputs:
  381. XC`09`09P_DATA`09Data buffer to send.
  382. XC`09`09P_LEN`09The data length.
  383. XC`09`09P_NUM`09The packet number.
  384. XC`09`09P_TYPE`09The packet type.
  385. XC
  386. XC`09Outputs:
  387. XC`09`09None.
  388. XC
  389. X`09IMPLICIT NONE
  390. X`09INCLUDE 'kermit_inc.for'
  391. X
  392. X`09BYTE`09P_DATA (MAXDATASIZ)
  393. X`09BYTE`09P_LEN, P_NUM, P_TYPE
  394. X
  395. X`09INTEGER I, PBYTES, PSIZE, PCHK
  396. X`09INTEGER KERMIT_CHECKSUM
  397. XC
  398. XC`09+------+-----------+-----------+------+--------------+-------+
  399. XC`09`7C MARK `7C char(LEN) `7C char(SEQ) `7C TYPE `7C ... DATA ... `7C CHECK
  400. V `7C
  401. XC`09+------+-----------+-----------+------+--------------+-------+
  402. XC`09       `7C<---- Packet Length / Check Calculation ---->`7C
  403. X
  404. XC
  405. XC`09Send out required pad characters (if any).
  406. XC
  407. X`09DO I = 1, PAD
  408. X`09    CALL SEND_BYTE (PADC)`09`09! Write the pad character.
  409. X`09ENDDO
  410. XC
  411. XC`09Construct the packet to send.
  412. XC
  413. X`09PACKET(PMARK) = MARKC`09`09`09! Copy the MARK character.
  414. X`09PACKET(PLEN) = P_LEN + POVER + 32`09! Set the packet size.
  415. X`09PACKET(PSEQ) = P_NUM + 32`09`09! Set the packet number.
  416. X`09PACKET(PTYPE) = P_TYPE`09`09`09! Set the packet type.
  417. X`09DO I = 1, P_LEN
  418. X`09    PACKET(PDATA+(I-1)) = P_DATA(I)`09! Copy packet data.
  419. X`09ENDDO
  420. X`09PSIZE = P_LEN + POVER`09`09`09! Set the packet size.
  421. X`09PCHK = PSIZE + TO_CHECK`09`09`09! Set offset to checksum.
  422. X`09PACKET(PCHK) = KERMIT_CHECKSUM (PACKET(PLEN), PSIZE) + 32
  423. X`09PACKET(PCHK+1) = EOLC`09`09`09! Set end of line character.
  424. X`09PBYTES = P_LEN + TOVER`09`09`09! Set total packet size.
  425. X`09CALL RAW_WRITE (PACKET, PBYTES)`09`09! Write the packet.`09
  426. X`09RETURN
  427. X`09END
  428. X`0C
  429. X`09INTEGER FUNCTION DEFAULT_PARAMETERS
  430. XC
  431. XC`09This function setup the default init parameters.  These defaults
  432. XC`09are used if the remote doesn't specify the parameter in its'
  433. XC`09send-init packet (all parameters are optional).
  434. XC
  435. X`09IMPLICIT NONE
  436. X`09INCLUDE 'kermit_inc.for'
  437. X`09INCLUDE 'bbs_inc.for'
  438. XC
  439. XC`09Setup the default init parameters.
  440. XC
  441. X`09SPSIZ  = DEFMAXL`09`09! Set maximum packet length.
  442. X`09TIMOUT = DEFTIME`09`09! Set timeout limit to use.
  443. X`09PAD    = DEFNPAD`09`09! Set number of pad characters.
  444. X`09PADC   = DEFPADC`09`09! Set pad character to use.
  445. X`09EOLC   = DEFEOLC`09`09! Set end of line character.
  446. X`09QCTLC  = DEFQCTL`09`09! Set control quote character.
  447. X`09QBINC  = DEFQBIN`09`09! Set eight bit quote character.
  448. X`09CHKTYP = DEFCHKT`09`09! Set the packet check type.
  449. X`09REPTC  = DEFREPT`09`09! Set the repeat character.
  450. X`09CAPAS  = DEFCAPAS`09`09! Set extended capabilities.
  451. XC
  452. XC`09Initialize other flags:
  453. XC
  454. X`09MARKC = SOH`09`09`09! Set the mark (start) character.
  455. X`09IMAGE = .FALSE.`09`09`09! Presume not image mode.
  456. X`09QBIN = .FALSE.`09`09`09! Set no eight bit quoting.
  457. X`09REPEAT = .FALSE.`09`09! Set no repeat char processing.
  458. X`09TURN = .FALSE.`09`09`09! Presume no turnaround char.
  459. X`09FILNAMCNV = .FALSE.`09`09! Presume no filename convert.
  460. XC
  461. XC`09Set the KERMIT end of line character in the read terminator table.
  462. XC
  463. X`09CALL SET_TERMINATOR (TPTR, TTBL, EOLC)`09! Set EOL terminator.
  464. X`09RETURN
  465. X`09END
  466. X`0C
  467. X`09INTEGER FUNCTION RECEIVE_PARAMETERS (RDATA, RLEN)
  468. XC
  469. XC`09This function is used to set the receive init parameters.
  470. XC
  471. XC`09Inputs:
  472. XC`09`09RDATA`09Buffer with the receive init parameters.
  473. XC`09`09RLEN`09The number of parameters received.
  474. XC
  475. XC`09Outputs:
  476. XC`09`09None.
  477. XC
  478. X`09IMPLICIT NONE
  479. X`09INCLUDE 'kermit_inc.for'
  480. X`09INCLUDE 'bbs_inc.for'
  481. X
  482. X`09BYTE`09RDATA (ISIZE), RLEN
  483. XC
  484. XC`09Copy the received init parameters (all params are optional).
  485. XC
  486. X`09IF (RLEN .GE. IMAXL) THEN
  487. X`09    SPSIZ  = RDATA (IMAXL) - 32`09! Set maximum packet length.
  488. X`09ENDIF
  489. X`09IF (RLEN .GE. ITIME) THEN
  490. X`09    TIMOUT = RDATA (ITIME) - 32`09! Set timeout limit to use.
  491. X`09    IF (TIMOUT .EQ. 0) THEN
  492. X`09`09TIMOUT = TIMEOUT_COUNT`09! Use our timeout count.
  493. X`09    ENDIF
  494. X`09ENDIF
  495. X`09IF (RLEN .GE. INPAD) THEN
  496. X`09    PAD    = RDATA (INPAD) - 32`09! Set number of pad characters.
  497. X`09ENDIF
  498. X`09IF (RLEN .GE. IPAD) THEN
  499. X`09    PADC = RDATA (IPAD) .XOR. 64 ! Set pad character to use.
  500. X`09ENDIF
  501. X`09IF (RLEN .GE. IEOLC) THEN
  502. X`09    EOLC   = RDATA (IEOLC) - 32`09! Set end of line character.
  503. X`09ENDIF
  504. X`09IF (RLEN .GE. IQCTL) THEN
  505. X`09    QCTLC  = RDATA (IQCTL)`09! Set control quote character.
  506. X`09    IF (QCTLC .EQ. 0) THEN
  507. X`09`09QCTLC = DEFQCTL`09`09! Set the default quote char.
  508. X`09    ENDIF
  509. X`09ENDIF
  510. X`09IF (RLEN .GE. IQBIN) THEN
  511. X`09    QBINC  = RDATA (IQBIN)`09! Set eight bit quote character.
  512. X`09ENDIF
  513. X`09IF (RLEN .GE. ICHKT) THEN
  514. X`09    CHKTYP = RDATA (ICHKT)`09! Set the packet check type.
  515. X`09ENDIF
  516. X`09IF (RLEN .GE. IREPT) THEN
  517. X`09    REPTC  = RDATA (IREPT)`09! Set the repeat character.
  518. X`09ENDIF
  519. X`09IF (RLEN .GE. ICAPAS) THEN
  520. X`09    CAPAS = RDATA (ICAPAS) - 32`09! Set extended capabilities.
  521. X`09ENDIF
  522. XC
  523. XC`09Change the read terminator table if the end of line character
  524. XC`09has been changed by the remote.
  525. XC
  526. X`09IF (EOLC .NE. DEFEOLC) THEN`09! If NE, different EOL char.
  527. X`09    CALL SET_TERMINATOR (TPTR, TTBL, EOLC) ! Set new terminator.
  528. X`09ENDIF
  529. X`09RETURN
  530. X`09END
  531. X`0C
  532. X`09INTEGER FUNCTION KSEND_PARAMETERS (SDATA)
  533. XC
  534. XC`09This function is used to set our init parameters.
  535. XC
  536. XC`09Inputs:
  537. XC`09`09SDATA`09Buffer for our init parameters.
  538. XC
  539. XC`09Outputs:
  540. XC`09`09None.
  541. XC
  542. X`09IMPLICIT NONE
  543. X`09INCLUDE 'kermit_inc.for'
  544. X`09INCLUDE 'bbs_inc.for'
  545. X
  546. X`09BYTE`09SDATA (ISIZE)
  547. XC
  548. XC`09Setup our init parameters.
  549. XC
  550. X`09SDATA (IMAXL) = PACKET_LENGTH + 32`09! Set maximum packet length.
  551. X`09SDATA (ITIME) = TIMEOUT_COUNT + 32`09! Set timeout limit to use.
  552. X`09SDATA (INPAD) = MYNPAD + 32`09`09! Set number of pad characters.
  553. X`09SDATA (IPAD)  = MYPADC .XOR. 64`09`09! Set pad character to use.
  554. X`09SDATA (IEOLC) = MYEOLC + 32`09`09! Set end of line character.
  555. X`09SDATA (IQCTL) = MYQCTL`09`09`09! Set control quote character.
  556. X`09SDATA (IQBIN) = MYQBIN`09`09`09! Set eight bit quote character.
  557. X`09SDATA (ICHKT) = MYCHKT`09`09`09! Set the packet check type.
  558. X`09SDATA (IREPT) = MYREPT`09`09`09! Set the repeat character.
  559. X`09SDATA (ICAPAS) = MYCAPAS + 32`09`09! Set extended capabilities.
  560. X`09RETURN
  561. X`09END
  562. X`0C
  563. X`09SUBROUTINE UNEXPECTED_STATE (MODULE, BSTATE)
  564. XC
  565. XC`09This routine is called whenever an unexpected state is found
  566. XC`09to report the current state to the user.
  567. XC
  568. XC`09Inputs:
  569. XC`09`09MODULE`09The module name.`09`09`09(By Descriptor)
  570. XC`09`09BSTATE`09The bad state detected.`09`09`09(By Reference)
  571. XC
  572. XC`09Outputs:
  573. XC`09`09None.
  574. XC
  575. X`09IMPLICIT NONE
  576. X`09INCLUDE 'kermit_inc.for'
  577. X
  578. X`09CHARACTER*(*) MODULE
  579. X`09BYTE BSTATE
  580. X
  581. X`09CHARACTER*(*) SS
  582. X`09PARAMETER (SS = CHAR(13)//CHAR(10))`09! Single space.
  583. X
  584. X`09CALL WRITE_USER (SS//
  585. X`091`09'*** Unexpected state in module "'//MODULE//'", state = '//
  586. X`092`09CHAR(BSTATE)//' ***'//SS)
  587. X`09RETURN
  588. X`09END
  589. X`0C
  590. X`09subroutine read_mail(mess,irec,status,nostop,next_mess)
  591. Xcccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
  592. Vcccc
  593. Xc
  594. Xc`09UBBS subroutines
  595. Xc`09This routine will read a message, display it on the screen,
  596. Xc`09and then give the user a menu of options.
  597. Xc
  598. Xc`09Dale Miller - UALR
  599. Xc
  600. Xc
  601. Xc`09Rev. 3.5  19-Jun-1986
  602. Xc`09Rev. 4.5  29-Aug-1986
  603. Xc`09Rev. 4.7  29-Nov-1986
  604. Xc`09Rev. 5.5  19-Jan-1988
  605. Xc`09Rev. 5.6  04-Mar-1988
  606. Xc`09Rev. 6.1  08-Jun-1988
  607. Xc`09Rev. 7.0  29-Aug-1988
  608. Xc`09Rev. 7.3  20-Jan-1989
  609. Xc`09Rev. 7.4  24-jul-1989
  610. Xc
  611. Xcccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
  612. Vcccc
  613. X`09implicit none
  614. X`09include 'bbs_inc.for/nolist'
  615. X`09include 'sys$library:foriosdef/nolist'
  616. X
  617. X`09external     bbs_get_input,bbs_put_output
  618. X
  619. X`09character    line*80,pm*14/' ** private **'/,xxx*4
  620. X`09character    cdummy*1,zmail_to*30,zmail_from*30
  621. X`09character    snum*6,qmail_to*30,yesno*3,string*30,lms*9
  622. X`09character    zfirst_name*20,zlast_name*20,defcmd*1
  623. X`09logical*1    flag,reprint,found,nostop,busy
  624. X`09byte         dummyb
  625. X        integer      status,err,next_mess,irec,mess,zz,istat
  626. X`09integer      dummy1,dummy2,dummy3,ii,x,dummy,kstatus,spc
  627. X        integer      hold_messnum,qq,jj
  628. X`09integer      str$upcase,str$trim,sys$asctim,lbr$output_help
  629. X`09integer      lib$wait
  630. X
  631. X`09record /userlog_structure/ zur
  632. X
  633. X`09record /mail_header_structure/ mh
  634. X
  635. X 1001`09format(a)
  636. X 1011`09format(i<dummy>)
  637. X 1013`09format(a,i2,'>')
  638. X 1015`09format(a,i2,1x,a)
  639. X 1019`09format(a,'Section #',i1,' - ',a)
  640. X`09status=0
  641. X`09err=0
  642. X
  643. Xc`09Step 1.  Get in the general area of the message
  644. X`09found=.false.
  645. X`09next_mess=0
  646. X`09
  647. X`09do while(.not.found)
  648. X`09    irec=irec+20
  649. X`09    if(irec.gt.last_header) found=.true.
  650. X`09    read(2,rec=irec,iostat=ios)mh
  651. X`09    if(ios.eq.for$ios_errdurrea) found = .true.
  652. X`09    unlock(unit=2)
  653. X`09    if(mh.mail_messnum.ge.mess) found=.true.
  654. X`09    end do
  655. X`09irec=irec-20
  656. X
  657. Xc`09We are now within 20 reads of the message
  658. X
  659. X`09found=.false.
  660. X`09do while(.not.found)
  661. X`09    if(irec.gt.last_header) found=.true.
  662. X`09    read(2,rec=irec,iostat=ios,err=90600) mh
  663. X`09    unlock(unit=2)
  664. X`09    if(mh.mail_messnum.ge.mess) then
  665. X`09`09found=.true.
  666. X`09    else
  667. X`09`09irec=irec+1
  668. X`09    end if
  669. X`09    end do
  670. X`09if(mh.mail_messnum.gt.mess) then
  671. X`09    next_mess=mh.mail_messnum
  672. X`09    irec=irec-1
  673. X`09    go to 20000
  674. X`09    end if
  675. X`09if(mh.mail_deleted.and.(.not.sysop)) go to 20000
  676. X`09zz=mh.mail_section
  677. X`09dummyb=2**zz
  678. X`09istat=str$upcase(zmail_to,mh.mail_to)
  679. X`09istat=str$upcase(zmail_from,mh.mail_from)
  680. X
  681. X`09if((zmail_to.ne.mail_name).and.
  682. X`091   ((dummyb.and.ur.auth_sections).eq.0)) go to 20000
  683. X
  684. X`09if(mh.mail_messnum.eq.mess.and.mh.mail_private) then
  685. X`09    if((mail_name.ne.zmail_to).and.
  686. X`091`09(mail_name.ne.zmail_from).and.(.not.sysop)) then
  687. X`09`09go to 20000
  688. X`09`09end if
  689. X`09    end if
  690. X`09if(mh.mail_messnum.eq.mess) then
  691. X`09    status=-1`09`09`09`09`09! We read it
  692. X`09    istat=str$trim(mh.mail_from,mh.mail_from,dummy1)
  693. X`09    istat=str$trim(mh.mail_to,mh.mail_to,dummy2)
  694. X`09    istat=str$trim(mh.mail_subject,mh.mail_subject,dummy3)
  695. X`09    if(dummy1.lt.1.or.dummy1.gt.30) dummy1=30
  696. X`09    if(dummy2.lt.1.or.dummy2.gt.30) dummy2=30
  697. X`09    if(dummy3.lt.1.or.dummy3.gt.30) dummy3=30
  698. X`09    xxx = '    '
  699. X`09    write(6,1019)crlf(:cl)//ffeed(:fl),mh.mail_section,
  700. X`091`09secnam(mh.mail_section+1)
  701. X`09    call ctrl_o_check(*21000,*10580)
  702. X`09    call comint(mh.mail_messnum,lms)
  703. X`09    write(6,1001)crlf(:cl)//'Message number:'//lms//' on '//
  704. X`091`09mh.mail_date//' at '//mh.mail_time
  705. X`09    call ctrl_o_check(*21000,*10580)
  706. X`09    if(mh.mail_read) xxx = ' (X)'
  707. X`09    if(mh.mail_private) then
  708. X`09`09write(6,1001)crlf(:cl)//
  709. X`091`09    '   From: '//mh.mail_from(1:dummy1)//pm
  710. X`09    else
  711. X`09`09write(6,1001)crlf(:cl)//'   From: '//mh.mail_from(1:dummy1)
  712. X`09    end if
  713. X`09    call ctrl_o_check(*21000,*10580)
  714. X`09    write(6,1001)crlf(:cl)//'     To: '//Mh.mail_to(1:dummy2)//xxx
  715. X`09    call ctrl_o_check(*21000,*10580)
  716. X`09    if(mh.mail_reply_to.eq.0) then
  717. X`09`09write(6,1001)crlf(:cl)//'Subject: '//mh.mail_subject(1:dummy3)
  718. X`09    else
  719. X`09`09call comint(mh.mail_reply_to,lms)
  720. X`09`09write(6,1001)crlf(:cl)//'Subject: #'//lms//'-'//
  721. X`091`09    mh.mail_subject(1:dummy3)
  722. X`09    end if
  723. X`09    if((sysop2).and..not.mh.mail_person) then
  724. X`09`09istat=sys$asctim(,string,mh.mail_expire,)
  725. X`09`09write(6,1001)' -- Expires on: '//string(1:11)
  726. X`09`09end if
  727. X`09    call ctrl_o_check(*21000,*10580)
  728. X`09    if(mh.mail_deleted) write(6,1001)crlf(:cl)//'**** deleted ****'
  729. X`09    write(6,1001)crlf(:cl)
  730. X`09    do ii=mh.mail_first,mh.mail_last
  731. X`09`09read(3,rec=ii,iostat=ios)line
  732. X`09`09unlock(unit=3)
  733. X`09`09call ctrl_o_check(*21000,*10580)
  734. X`09`09istat=str$trim(line,line,x)
  735. X`09`09write(6,1001)crlf(:cl)//line(1:x)
  736. X`09`09end do
  737. X`09    write(6,1001)crlf(:cl)
  738. X`09    end if
  739. X`09if((mh.mail_messnum.eq.mess).and.(.not.mh.mail_read).and.
  740. X`091    (zmail_to.eq.mail_name)) then
  741. X`09    read(2,rec=irec,iostat=ios,err=90600) mh
  742. X`09    mh.mail_read=.true.
  743. X`09    write(2,rec=irec,err=90600,iostat=ios) mh
  744. X`09    read(1,key=ur.user_key,iostat=ios,err=90500)ur
  745. X`09    ur.num_unread=ur.num_unread-1
  746. X`09    if(ur.num_unread.lt.0) ur.num_unread=0
  747. X`09    if(mess.gt.ur.last_message.and.area.ne.'marked')
  748. X`091`09ur.last_message=mess
  749. X`09    rewrite(1,err=90500)ur
  750. X`09    end if
  751. X`09if (area.eq.'marked') go to 10580
  752. X`09if(mess.gt.ur.last_message) then
  753. X10540`09    read(1,key=ur.user_key,iostat=ios,err=90500)ur
  754. X`09    if(area.ne.'marked')ur.last_message=mess
  755. X`09    rewrite(1,err=90500,iostat=ios)ur
  756. X`09    end if
  757. X10580`09continue
  758. X`09if(nostop.and.(zmail_to.ne.mail_name)) return
  759. X10590`09continue
  760. X`09if(zmail_to.eq.mail_name) then
  761. X`09    defcmd='K'
  762. X`09else
  763. X`09    defcmd='C'
  764. X`09endif
  765. X
  766. X10591`09continue
  767. X`09if(reprint) then
  768. X`09    reprint=.false.
  769. X`09    write(6,1001)crlf(:cl)//'(C)ontinue     (E)nd'
  770. X`09    write(6,1001)crlf(:cl)//'(H)elp         (K)ill'
  771. X`09    write(6,1001)crlf(:cl)//'(N)ostop       (R)eply'
  772. X`09    write(6,1001)crlf(:cl)//crlf(:cl)//'Command? `5B'//defcmd//'`5D'
  773. X`09else
  774. X`09    write(6,1001)crlf(:cl)//
  775. X`091`09'Command (C,E,H,K,N,R,?)? `5B'//defcmd//'`5D '
  776. X`09end if
  777. X`09dummy=1
  778. X`09call get_uplow_string(cdummy,dummy)
  779. X`09istat=str$upcase(cdummy,cdummy)
  780. X`09if(dummy.eq.0) cdummy=defcmd
  781. X`09if(cdummy.eq.'C') go to 20000
  782. X`09if(cdummy.eq.'E') go to 21000
  783. X`09if(cdummy.eq.'H') go to 22000
  784. X`09if(cdummy.eq.'K') go to 22500
  785. X`09if(cdummy.eq.'N') go to 23000
  786. X`09if(cdummy.eq.'P'.and.sysop2) go to 22700`09! Make message private
  787. X`09if(cdummy.eq.'R') go to 24000
  788. X`09if(cdummy.eq.'U'.and.sysop2) go to 22600`09`09! undelete message
  789. X`09if(cdummy.eq.'?') then
  790. X`09    reprint=.true.
  791. X`09    go to 10591
  792. X`09    end if
  793. X
  794. X`09write(6,1001)crlf(:cl)//'That was not a valid command'
  795. X`09go to 10591
  796. X
  797. X20000`09continue`09`09!Continue
  798. X`09return
  799. X
  800. X21000`09continue`09`09!Exit
  801. X`09status=3
  802. X`09return
  803. X
  804. X22000`09continue`09`09!Help
  805. X`09controlc_typed=.false.
  806. X`09istat=lbr$output_help(bbs_put_output,,
  807. X`091   'bbs_help retrieve','ubbs_data:helplib',,bbs_get_input)
  808. X`09go to 10591
  809. X
  810. X
  811. X22500`09continue`09`09!Kill message
  812. X`09call kill_mess (irec,kstatus)
  813. X`09if(kstatus.eq.1) go to 90500
  814. X`09if(kstatus.eq.2) go to 90600
  815. X`09DEFCMD='C'
  816. X`09go to 10591
  817. X
  818. X22600`09continue`09`09!Unkill message
  819. X`09read(2,rec=irec,iostat=ios,err=90600) mh
  820. X
  821. X`09mh.mail_deleted=.false.
  822. X`09write(2,rec=irec,iostat=ios,err=90600) mh
  823. X`09write(6,1001)crlf(:cl)//'Message restored'
  824. X`09go to 10591
  825. X
  826. X22700`09continue`09`09!Make message private
  827. X`09read(2,rec=irec,iostat=ios,err=90600) mh
  828. X`09mh.mail_private= .not. mh.mail_private
  829. X`09write(2,rec=irec,err=90600,iostat=ios) mh
  830. X`09if(mh.mail_private) then
  831. X`09    write(6,1001)crlf(:cl)//'Message is now private'
  832. X`09else
  833. X`09    write(6,1001)crlf(:cl)//'Message is now public'
  834. X`09end if
  835. X`09go to 10591
  836. X
  837. X23000`09continue`09`09!Nostop
  838. X`09nostop=.true.
  839. X`09return
  840. X
  841. X24000`09continue`09`09!Reply
  842. X`09if (.not.approved_mail_send) go to 10591
  843. X`09mh.mail_person=.true.
  844. X`09mh.mail_private=.false.
  845. X`09zmail_to=mh.mail_from
  846. X`09istat=str$upcase(qmail_to,zmail_to)
  847. X`09spc=index(qmail_to,' ')
  848. X`09zfirst_name=qmail_to(1:spc-1)
  849. X`09do ii=spc+1,30
  850. X`09    if(zmail_to(ii:ii).ne.' ') go to 3010
  851. X`09    end do
  852. Xc`09no last name found.
  853. X`09write(6,1001)crlf(:cl)//'There seems to be some problem here'//
  854. X`091    crlf(:cl)//'This person does not exist!'
  855. X`09go to 10591
  856. X3010`09zlast_name=qmail_to(ii:30)
  857. X`09zur.user_key=zlast_name//zfirst_name
  858. X`09dummy=0
  859. X`09hold_messnum=mh.mail_messnum
  860. X`09mh.mail_private=.false.
  861. X`09write(6,1001)crlf(:cl)//'Is this a private message? `5Bno`5D'
  862. X`09dummy=3
  863. X`09call get_upcase_string(yesno,dummy)
  864. X`09if(yesno(1:1).eq.'Y') mh.mail_private=.true.
  865. X`09ii=20
  866. X`09call enter_message(ii,*3040,0)
  867. X`09mh.mail_read=.false.
  868. X`09mh.mail_deleted=.false.
  869. X`09mh.mail_to=zmail_to
  870. X`09mh.mail_from=mail_name
  871. X`09call modify_mail_info(mh,*3040)
  872. X
  873. X 3020`09read(2,rec=1,iostat=ios,err=90500)last_header, last_data,
  874. X`091   first_mnum,last_mnum,busy
  875. X`09if(busy) then
  876. X`09    unlock(unit=2)
  877. X`09    dummy=lib$wait(1.0)
  878. X`09    go to 3020
  879. X`09    end if
  880. X`09last_header=last_header+1
  881. X`09last_mnum=last_mnum+1
  882. X`09write(2,rec=1)last_header,last_data+ii,first_mnum,last_mnum
  883. X`09call date(mh.mail_date)
  884. X`09call time(mh.mail_time)
  885. X`09mh.mail_reply_to=mh.mail_messnum
  886. X`09mh.mail_messnum=last_mnum
  887. X`09mh.mail_first=last_data+1
  888. X`09mh.mail_last=last_data+ii
  889. X`09do qq=1,10
  890. X`09    mh.mail_replys(qq)=0
  891. X`09    end do
  892. X
  893. Xc`09write the header
  894. X`09write(2,rec=last_header,err=90600,iostat=ios) mh
  895. X
  896. Xc`09and the message
  897. X`09do jj=1,ii
  898. X`09    write(3,rec=last_data+jj)message(jj)
  899. X`09    end do
  900. X
  901. Xc`09now, set up for read thread
  902. X`09read(2,rec=irec,iostat=ios,err=90600) mh
  903. X`09qq=1
  904. X`09do while(mh.mail_replys(qq).ne.0.and.qq.lt.11)
  905. X`09    qq=qq+1
  906. X`09    end do
  907. X`09if(qq.le.10.and.mh.mail_replys(qq).eq.0) mh.mail_replys(qq)=last_mnum
  908. X`09write(2,rec=irec,iostat=ios,err=90600) mh
  909. X
  910. Xc`09tell him about it
  911. X`09call comint(last_mnum,lms)
  912. X`09write(6,1001)crlf(:cl)//' Message number'//lms//
  913. X`091   ' sent.'//bell//bell
  914. X
  915. Xc`09tell reciever he has mail
  916. X`09if(.not.mh.mail_person) go to 10591
  917. X
  918. X`09read(1,key=zur.user_key,iostat=ios,err=10591)zur
  919. X`09zur.num_unread = zur.num_unread+1
  920. X`09rewrite(1,err=90500,iostat=ios)zur
  921. X
  922. X`09go to 10591`09`09`09!Ask him for another command
  923. X
  924. Xc`09Come here if he aborted reply to fix up header again.
  925. X3040`09read(2,rec=irec,iostat=ios,err=90600) mh
  926. X`09go to 10591
  927. X
  928. X90500`09status=1`09!error on userlog
  929. X`09return
  930. X
  931. X90600`09status=2`09!error on message files
  932. X`09return
  933. X
  934. X`09end
  935. X
  936. X`0C
  937. X`09subroutine modify_mail_info (mh,*)
  938. Xcccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
  939. Vcccc
  940. Xc
  941. Xc`09UBBS subroutines
  942. Xc`09This routine will allow a user to change the parameters on a message
  943. Xc`09before sending it.
  944. Xc
  945. Xc`09Dale Miller - UALR
  946. Xc
  947. Xc
  948. Xc`09Rev. 5.6  04-Mar-1988
  949. Xc
  950. Xcccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
  951. Vcccc
  952. X`09implicit none
  953. X`09include 'bbs_inc.for/nolist'
  954. X`09include '($foriosdef)'
  955. X
  956. X`09character    cdummy*1,zmail_subject*30,zmail_to*30,qmail_to*30,yesno*3
  957. X`09character    zlast_name*20,zfirst_name*20,pdummy*3,dummy_20*20
  958. X`09character    string*20
  959. X`09logical      dummyl
  960. X`09real*8       right_now,rdummy,day_31
  961. X`09integer      dummy,ii,namln,istat,spc,kk,sect,compquad
  962. X`09integer      str$upcase,sys$gettim,sys$asctim,sys$bintim,str$trim
  963. X
  964. X`09record /userlog_structure/     zur
  965. X`09record /mail_header_structure/ mh
  966. X
  967. X 1001`09format(a)
  968. X 1011`09format(i1)
  969. X 1020`09format(a,i1,' - ',a)
  970. X
  971. X`09istat = sys$bintim('18-DEC-1858 00:00:00',day_31)
  972. X 0010`09write(6,1001)crlf(:cl)//
  973. X`091   'Options: (S)end, (M)odify, (A)bort `5Bsend`5D?'
  974. X`09dummy=1
  975. X`09call get_upcase_string(cdummy,dummy)
  976. X`09if(dummy.eq.0.or.cdummy.eq.'S') then
  977. X`09    return
  978. X`09else if(cdummy.eq.'A') then
  979. X`09    write(6,1001)crlf(:cl)//'Message send aborted'
  980. X`09    return 1
  981. X`09else if(cdummy.ne.'M') then
  982. X`09    write(6,1001)crlf(:cl)//bell//
  983. X`091`09'Unrecognized option -- please try again'
  984. X`09    go to 0010
  985. Xc`09He has elected to change this message.  Step through the possibilities
  986. X`09end if
  987. X
  988. X`09write(6,1001)crlf(:cl)//crlf(:cl)//'Message is to: `5B'//
  989. X`091  mh.mail_to//'`5D'
  990. X`09namln=30
  991. X`09call get_uplow_string(zmail_to,namln)
  992. X`09istat=str$upcase(qmail_to,zmail_to)
  993. X`09if(namln.eq.0.or.zmail_to.eq.mh.mail_to) then
  994. X`09    go to 0200`09`09`09`09! No change, that's easy.
  995. X`09    end if
  996. X`09mh.mail_to = zmail_to
  997. X`09mh.mail_person = .true.`09`09`09! Assume an individual
  998. X`09spc=index(qmail_to,' ')
  999. X`09zfirst_name=qmail_to(1:spc-1)`09
  1000. X`09do ii=spc+1,30
  1001. X`09    if(zmail_to(ii:ii).ne.' ') go to 0110
  1002. X`09    end do
  1003. Xc`09No last name found.  This must be a public message
  1004. X`09mh.mail_person=.false.
  1005. X`09go to 0200`09!no need to check further
  1006. X
  1007. X 0110`09zlast_name=qmail_to(ii:30)
  1008. X`09zur.user_key=zlast_name//zfirst_name
  1009. X`09read(1,key=zur.user_key,iostat=ios)zur
  1010. X`09unlock(unit=1)
  1011. X`09if(ios.ne.0) mh.mail_person=.false.`09`09!Error on read
  1012. X
  1013. X 0200`09write(6,1001)crlf(:cl)//'      Subject: `5B'//mh.mail_subject//'`5D'
  1014. X`09dummy=20
  1015. X`09call get_uplow_string(zmail_subject,dummy)
  1016. X`09if(dummy.eq.0.or.zmail_subject.eq.mh.mail_subject) then
  1017. X`09    continue
  1018. X`09else
  1019. X`09    mh.mail_subject = zmail_subject
  1020. X`09end if
  1021. X`09if(.not.mh.mail_person) then
  1022. X 3031`09    continue
  1023. X`09    right_now = mh.mail_expire
  1024. X`09    istat=sys$asctim(,dummy_20,right_now,)
  1025. X`09    mh.mail_private=.false.
  1026. X`09    write(6,1001)crlf(:cl)//
  1027. X`091`09'What is the expiration date for this message? `5B'//
  1028. X`092`09dummy_20(:11)//'`5D'
  1029. X`09    dummy=11
  1030. X`09    call get_uplow_string(string,dummy)
  1031. X`09    istat=str$upcase(string,string)
  1032. X`09    if(dummy.eq.0) then
  1033. X`09`09mh.mail_expire=right_now
  1034. X`09    else
  1035. X`09`09istat=sys$bintim(string(:11)//' 00:00:00',mh.mail_expire)
  1036. X`09    end if
  1037. X`09    dummy=compquad(mh.mail_expire,right_now)
  1038. X`09    if(dummy.eq.-1) then
  1039. X`09`09write(6,1001)crlf(:cl)//
  1040. X`091`09    'That is not a valid date.  Dates must be of the'//
  1041. X`092`09    crlf(:cl)//'form dd-mmm-yyyy (e.g. 01-Jan-1986)'
  1042. X`09`09go to 3031
  1043. X`09    end if
  1044. X`09    call addquad(right_now,day_31,rdummy)
  1045. X`09    dummy=compquad(rdummy,mh.mail_expire)
  1046. X`09    if(dummy.eq.-1) then
  1047. X`09`09write(6,1001)crlf(:cl)//
  1048. X`091`09    'Your expiration date may be no more than 1 month in'//
  1049. X`092`09    crlf(:cl)//'the future.  Please try again'
  1050. X`09`09go to 3031
  1051. X`09    end if
  1052. X`09    istat=sys$asctim(,string,mh.mail_expire,)
  1053. X`09else
  1054. X`09    if(mh.mail_private) then
  1055. X`09`09pdummy='Yes'
  1056. X`09    else
  1057. X`09`09pdummy='No'
  1058. X`09    end if
  1059. X`09    write(6,1001)crlf(:cl)//'Is this a private message?'//
  1060. X`091`09' `5B'//pdummy//'`5D'
  1061. X`09    dummy=3
  1062. X`09    call get_upcase_string(yesno,dummy)
  1063. X`09    if(yesno(1:1).eq.'Y') mh.mail_private=.true.
  1064. X`09    if(yesno(1:1).eq.'N') mh.mail_private=.false.
  1065. X`09end if
  1066. X
  1067. X 3080`09sect=mh.mail_section
  1068. X`09istat = str$trim(secnam(sect+1),secnam(sect+1),dummy)
  1069. X`09write(6,1001)crlf(:cl)//'Section number? (enter 9 for list)'//
  1070. X`091   '`5B'//char(sect+48)//' - '//secnam(sect+1)(:dummy)//'`5D'
  1071. X`09dummy=1
  1072. X`09dummyl=.false.
  1073. X`09call get_number(string,dummy,dummyl)
  1074. X`09if(string.eq.'9') then
  1075. X`09    do kk=0,7
  1076. X`09`09call ctrl_o_check(*3080,*3080)
  1077. X`09`09write(6,1020)crlf(:cl),kk,secnam(kk+1)
  1078. X`09`09end do
  1079. X`09    go to 3080
  1080. X`09else if (dummy.eq.0) then
  1081. X`09    go to 0010
  1082. X`09    end if
  1083. X`09read(string,1011)sect
  1084. X`09if(sect.gt.7) then
  1085. X`09    write(6,1001)crlf(:cl)//'Invalid section number'
  1086. X`09    go to 3080
  1087. X`09    end if
  1088. X`09mh.mail_section=sect
  1089. X`09go to 0010
  1090. X
  1091. X 0300`09continue
  1092. X`09return
  1093. X`09end
  1094. X`0C
  1095. X`09subroutine ubbs_files_section
  1096. Xcccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
  1097. Vcccc
  1098. Xc
  1099. Xc`09UBBS subroutines
  1100. Xc`09This routine handles all of the UBBS file transfer.
  1101. Xc`09Dale Miller - UALR
  1102. Xc
  1103. Xc
  1104. Xc`09Rev. 3.5  19-Jun-1986
  1105. Xc`09Rev. 3.6  24-Jun-1986
  1106. Xc`09Rev. 4.0  27-Jun-1986
  1107. Xc`09Rev. 4.1  07-Jul-1986
  1108. Xc`09Rev. 4.2  20-Jul-1986
  1109. Xc       Rev. 4.6  09-Nov-1986
  1110. Xc`09Rev. 4.7  29-Nov-1986
  1111. Xc`09Rev. 4.10 11-Feb-1987
  1112. Xc`09Rev. 4.13 04-Jul-1987
  1113. Xc`09Rev. 4.14 12-Sep-1987
  1114. Xc`09Rev. 5.5  05-Jan-1988
  1115. Xc`09Rev. 5.6  03-Mar-1988
  1116. Xc`09Rev. 6.0  06-Jun-1988
  1117. Xc`09Rev. 6.1  08-Jun-1988
  1118. Xc`09Rev. 6.3  23-Aug-1988
  1119. Xc`09Rev. 7.0  29-Aug-1988
  1120. Xc`09Rev. 7.1  19-Sep-1988
  1121. Xcccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
  1122. Vcccc
  1123. X`09implicit none
  1124. X`09include 'bbs_inc.for/nolist'
  1125. X`09include 'sys$library:foriosdef/nolist'
  1126. X`09include '($rmsdef)'
  1127. X`09character cdummy*1,darea*3
  1128. X`09character filename*50,filnam*80,disk*4,line*200,ftyp*7
  1129. X`09character binasc*4,zfilnam*20,term*5,cdate*9,types*1,cdate2*11
  1130. X`09character space*30/'                    '/
  1131. X`09logical*1 reprint,dummyl
  1132. X`09integer i,istat,per,spc,length,flen
  1133. X`09integer dummy,dummy1,dummy2
  1134. X`09integer get_xmodem,send_xmodem,find_file,find_next
  1135. X`09integer kermit_send,kermit_receive
  1136. X`09integer fsize,rev_date(2),back_date(2)
  1137. X`09logical get_vaxfile
  1138. X`09integer lib$delete_file,str$trim,lib$find_file
  1139. X`09integer lbr$output_help,str$upcase,sys$gettim
  1140. X`09external getsize,bbs_put_output,bbs_get_input,uopen
  1141. X
  1142. X`09record /userlog_structure/ zur
  1143. X`09record/file_description/ fd
  1144. X
  1145. X`09common/filesize/fsize,rev_date,back_date
  1146. X
  1147. X 1001`09format(a)
  1148. X 1003`09format(q,a)
  1149. X 1004`09format('$!',a3,'=',a18,i3,1x,a)
  1150. X 1019`09format(a1,'file_',i6.6,'.dat')
  1151. X 1024   format(i5.5)
  1152. X
  1153. X`09ldesc.dsc$w_maxstrlen = buffer_size
  1154. X`09ldesc.dsc$a_pointer   = %loc(lbuffer)
  1155. X`09rdesc.dsc$w_maxstrlen = buffer_size
  1156. X`09rdesc.dsc$a_pointer   = %loc(rbuffer)
  1157. X`09xdesc.dsc$w_maxstrlen = buffer_size
  1158. X`09xdesc.dsc$a_pointer   = %loc(xbuffer)
  1159. X
  1160. X
  1161. Xc`09Start the whole thing off
  1162. X 4000`09continue
  1163. X`09call date(cdate)
  1164. X`09write(6,1001)crlf(:cl)//
  1165. X`091   '(D)ownload, (U)pload, (H)elp or (E)xit? `5Bexit`5D '
  1166. X`09dummy=1
  1167. X`09call get_upcase_string(cdummy,dummy)
  1168. X`09if(cdummy.eq.'E'.or.dummy.eq.0) go to 4900
  1169. X`09if(cdummy.eq.'D') go to 4100
  1170. X`09if(cdummy.eq.'U') go to 4700
  1171. X`09if(cdummy.eq.'H') then
  1172. X`09    controlc_typed=.false.
  1173. X`09    istat=lbr$output_help(bbs_put_output,,
  1174. X`091`09'bbs_help file_transfer','ubbs_data:helplib',,bbs_get_input)
  1175. X`09    go to 4000
  1176. X`09    end if
  1177. X`09write(6,1001)crlf(:cl)//'Invalid selection.  Please try again.'
  1178. X`09go to 4000
  1179. X
  1180. X 4100`09continue`09`09!Download
  1181. X`09area='download'
  1182. X`09if (.not.approved_file_down) then
  1183. X`09    write(6,1001)crlf(:cl)//bell//
  1184. X`091`09'You are not yet approved for the download section.'
  1185. X`09    write(6,1001)crlf(:cl)//'Sorry.'
  1186. X`09    return
  1187. X`09    end if
  1188. X`09flow=to_remote
  1189. X`09if(reprint.or.(.not.ur.xpert)) then
  1190. X`09    reprint=.false.
  1191. X`09    call type_file('ubbs_files:`5B000000`5Ddownload.areas')
  1192. X 4101`09    write(6,1001)crlf(:cl)//crlf(:cl)//
  1193. X`091`09'Enter area of interest? `5Bexit`5D'
  1194. X`09else
  1195. X`09    write(6,1001)crlf(:cl)//'Area? '
  1196. X`09end if
  1197. X`09dummy=3`09    `09   `20
  1198. X`09call get_uplow_string(darea,dummy)
  1199. X`09istat = str$upcase(darea,darea)
  1200. X`09if(dummy.eq.0.or.darea.eq.'EXI') go to 4900
  1201. X`09if(darea.eq.'?') then
  1202. X`09    reprint=.true.
  1203. X`09    go to 4100
  1204. X`09    end if
  1205. X`09dummy=0
  1206. X`09if (lib$find_file('ubbs_files:`5B'//darea//'`5Dallow.down',
  1207. X`091   filename,dummy).ne.rms$_normal) then
  1208. X`09    write(6,1001)crlf(:cl)//
  1209. X`091`09'That is not a valid area.  Please try again'
  1210. X`09    reprint=.true.
  1211. X`09    go to 4100
  1212. X`09    end if
  1213. Xc`09Offer to print the SYSOP bulletin, if it exists
  1214. X`09filnam = 'ubbs_files:`5B'//darea//'.asc`5Dsysop.bulletin'
  1215. X`09open(unit=4,file=filnam,status='old',readonly,
  1216. X`091   useropen=getsize,iostat=istat)
  1217. X
  1218. X`09if(istat.eq.0)then
  1219. X`09    call sys$asctim(,cdate2,rev_date,)
  1220. X`09    cdate2(5:5) = char(ichar(cdate2(5:5))+32)
  1221. X`09    cdate2(6:6) = char(ichar(cdate2(6:6))+32)
  1222. X`09    write(6,1001)crlf(:cl)//crlf(:cl)//
  1223. X`091`09'View FILE SYSOP bulletin - Rev. '//
  1224. X`092`09cdate2//'? `5Bno`5D'
  1225. X`09    dummy=1
  1226. X`09    call get_upcase_string(cdummy,dummy)
  1227. X`09    if(cdummy.eq.'Y') then
  1228. X`09`09call type_file(filnam)
  1229. X`09`09end if
  1230. X`09else
  1231. X`09    write(6,1001)crlf(:cl)//crlf(:cl)//
  1232. X`091`09'No FILE SYSOP bulletin today - please press <return>'
  1233. X`09    dummy=1
  1234. X`09    call get_upcase_string(cdummy,dummy)
  1235. X`09    end if
  1236. X
  1237. X 4150`09continue
  1238. Xc!`09Process users group areas separately
  1239. Xc!`09if(darea.eq.'CUG') goto 4160
  1240. X`09write(6,1001)crlf(:cl)//crlf(:cl)//
  1241. X`091'Enter name of file to download, ? for list, ?? to search,'
  1242. X`09write(6,1001)crlf(:cl)//'or <cr> to exit. '
  1243. X`09dummy=30
  1244. X`09call get_uplow_string(filename,dummy)
  1245. X`09istat=str$upcase(filename,filename)
  1246. X`09if(dummy.eq.0) go to 4900
  1247. X`09if(filename.eq.'?') then
  1248. X`09    call listcat(darea)
  1249. X`09    go to 4150`09   `20
  1250. X`09    end if
  1251. X`09if(filename.eq.'??') then
  1252. X`09    call searchcat(darea)
  1253. X`09    go to 4150`09   `20
  1254. X`09    end if
  1255. X`09if(filename.eq.'ABC.XYZ') go to 5000
  1256. X`09per=index(filename,'.')
  1257. X`09if(per.eq.0) then
  1258. X`09    spc=index(filename,' ')
  1259. X`09    filename(spc:spc)='.'
  1260. X`09    end if
  1261. X`09file_type=ascii`09`09`09!make assumption
  1262. X`09filnam='ubbs_files:`5B'//darea//'.asc`5D'//filename
  1263. X`09dummyl=get_vaxfile(filnam)
  1264. X`09if(dummyl) go to 4170
  1265. X`09file_type=binary`09`09!wrong assumption, try again
  1266. X`09filnam='ubbs_files:`5B'//darea//'.bin`5D'//filename
  1267. X`09dummyl=get_vaxfile(filnam)
  1268. X`09if(dummyl) go to 4170
  1269. Xc`09See if it is archived
  1270. X`09open(unit=4,`09`09shared,
  1271. X`091   file='ubbs_files:`5B'//darea//'`5Dfiles.idx',
  1272. X`092   status='old',`09organization='indexed',
  1273. X`093   access='keyed',`09form='unformatted',
  1274. X`094   recl=192,`09`09recordtype='variable',
  1275. X`095`09`09`09key=(1:18:character),
  1276. X`096   useropen=uopen)
  1277. X
  1278. X`09fd.file_name=filename
  1279. X`09istat=str$trim(fd.file_name,fd.file_name,dummy)
  1280. X`09if(fd.file_name(dummy:dummy).eq.'.') fd.file_name(dummy:dummy)=' '
  1281. X`09read(4,key=fd.file_name,iostat=ios)fd
  1282. X`09close(unit=4)
  1283. X`09if(fd.archived.and.(ios.eq.0)) then
  1284. X`09    write(6,1001)crlf(:cl)//'That file is currently stored off-line.'
  1285. X`09    write(6,1001)crlf(:cl)//'Files are restored each weeknight at'//
  1286. X`091`09' midnight.'
  1287. X`09    write(6,1001)crlf(:cl)//crlf(:cl)//
  1288. X`091`09'Do you wish to request a restore? `5BNo`5D'
  1289. X`09    dummy=1
  1290. X`09    call get_upcase_string(cdummy,dummy)
  1291. X
  1292. X`09    if(cdummy.eq.'Y') then
  1293. X`09`09open(unit=4,file='ubbs_data:to_restore.dat',
  1294. X`091`09    shared,access='append',carriagecontrol='list',
  1295. X`092`09    status='unknown')
  1296. X`09`09if(fd.file_type.eq.'A'.or.fd.file_type.eq.'U') then
  1297. X`09`09    write(4,1001)'`5B'//darea//'.ASC`5D'//filename
  1298. X`09`09else
  1299. X`09`09    write(4,1001)'`5B'//darea//'.BIN`5D'//filename
  1300. X`09`09end if
  1301. X`09`09close(unit=4)
  1302. X`09`09end if
  1303. X
  1304. X`09    go to 4150
  1305. X`09    end if
  1306. X`09write(6,1001)crlf(:cl)//bell//
  1307. X`091   'That is not a valid filename.  Try again.'
  1308. X`09go to 4150
  1309. X
  1310. X 4170`09if(file_type.eq.binary) then
  1311. X`09    protocol=asciid
  1312. X`09    write(6,1001)crlf(:cl)//'Binary files must be transferred via'
  1313. X`09    write(6,1001)crlf(:cl)//'Xmodem, Ymodem or Kermit'
  1314. X`09    protocol=unknown
  1315. X`09    do while(protocol.eq.unknown)
  1316. X`09`09write(6,1001)crlf(:cl)//
  1317. X`091`09    '(K)ermit (X)modem or (Y)modem transfer `5Bexit`5D'
  1318. X`09`09dummy=1
  1319. X`09`09call get_upcase_string(cdummy,dummy)
  1320. X`09`09if(dummy.eq.0.or.cdummy.eq.'E') go to 4150
  1321. X`09`09if(cdummy.eq.'K') protocol=kermit
  1322. X`09`09if(cdummy.eq.'X') protocol=xmodem
  1323. X`09`09if(cdummy.eq.'Y') protocol=ymodem
  1324. X`09`09end do
  1325. X`09else
  1326. X`09    protocol=unknown
  1327. X`09    do while(protocol.eq.unknown)
  1328. X`09`09write(6,1001)crlf(:cl)//
  1329. X`091`09    '(A)scii, (K)ermit (X)modem or (Y)modem transfer? `5Bexit`5D'
  1330. X`09`09dummy=1
  1331. X`09`09call get_upcase_string(cdummy,dummy)
  1332. X`09`09if(dummy.eq.0.or.cdummy.eq.'E') go to 4150
  1333. X`09`09if(cdummy.eq.'A') protocol=asciid
  1334. X`09`09if(cdummy.eq.'K') protocol=kermit
  1335. X`09`09if(cdummy.eq.'X') protocol=xmodem
  1336. X`09`09if(cdummy.eq.'Y') protocol=ymodem
  1337. X`09`09end do
  1338. X`09    end if
  1339. X
  1340. Xc
  1341. Xc`09File is open, protocol is selected.  Do it to it.
  1342. Xc
  1343. Xc! 4177`09continue
  1344. X`09if (protocol.eq.xmodem .or. protocol.eq.ymodem) then
  1345. X`09    call clear_counts()
  1346. X`09    timeout_count=10
  1347. X`09    retry_limit=5
  1348. X`09    bitmask=eightbit_mask
  1349. X`09    write(6,1001)crlf(:cl)//
  1350. X`091`09'Beginning Xmodem/Ymodem download -- Ctrl-x to abort.'
  1351. X`09    call init_timer(file_timer)
  1352. X`09    dummyl=send_xmodem()
  1353. X`09    bitmask=sevenbit_mask
  1354. X`09    call waitabit('10')
  1355. X`09    call elapsed_time(file_timer)`09!Display elapsed time
  1356. X`09    call report_totals()`09`09!Report final stats
  1357. X`09else if(protocol.eq.kermit) then
  1358. X`09    call clear_counts()
  1359. X`09    call default_parameters()
  1360. X`09    timeout_count=10
  1361. X`09    retry_limit=5
  1362. X`09    write(6,1001)crlf(:cl)//
  1363. X`091`09'Beginning Kermit download.'
  1364. X`09    call waitabit('2')
  1365. X`09    remote_file = filename
  1366. X`09    call init_timer(file_timer)
  1367. X`09    dummyl = kermit_send(ldesc, rbuffer, xbuffer)
  1368. X`09    call waitabit('10')
  1369. X`09    call elapsed_time(file_timer)`09!Display elapsed time
  1370. X`09    call report_totals()`09`09!Report final stats
  1371. X`09else`09`09!ascii dump
  1372. X`09    write(6,1001)crlf(:cl)//'Control-c to abort download'
  1373. X`09    write(6,1001)crlf(:cl)//'Open your capture buffer now.'
  1374. X`09    call waitabit('10')
  1375. X`09    call init_timer(file_timer)
  1376. X`09    dummyl = .false.
  1377. X`09    read(file_unit,1003,iostat=ios)length,line
  1378. X`09    do while(ios.eq.0)
  1379. X`09`09call out(line(1:length),*4200)
  1380. X`09`09read(file_unit,1003,iostat=ios)length,line
  1381. X`09`09end do
  1382. X`09    dummyl = .true.
  1383. X 4200`09    close (unit=file_unit)
  1384. X`09    call waitabit('10')
  1385. X`09    call elapsed_time(file_timer)
  1386. X`09end if
  1387. X
  1388. X`09if(dummyl) then
  1389. X`09    write(6,1001)crlf(:cl)//'Successful transfer'
  1390. X`09    ur.down_files=ur.down_files+1
  1391. X`09    read(1,key=ur.user_key)zur
  1392. X`09    rewrite(1,err=4150)ur
  1393. X
  1394. Xc`09Update the directory entry for this file.
  1395. X
  1396. X`09    open(unit=4,`09`09shared,
  1397. X`091   file='ubbs_files:`5B'//darea//'`5Dfiles.idx',
  1398. X`092   status='old',`09organization='indexed',
  1399. X`093   access='keyed',`09form='unformatted',
  1400. X`094   recl=192,`09`09recordtype='variable',
  1401. X`095`09`09`09key=(1:18:character),
  1402. X`096   useropen=uopen)
  1403. X
  1404. X`09    fd.file_name=filename
  1405. X`09    istat=str$trim(fd.file_name,fd.file_name,dummy)
  1406. X`09    if(fd.file_name(dummy:dummy).eq.'.') fd.file_name(dummy:dummy)=' '
  1407. X
  1408. X`09    read(4,key=fd.file_name,iostat=ios)fd
  1409. X
  1410. X`09    fd.times_down=fd.times_down+1
  1411. X`09    call sys$gettim(fd.download_date)
  1412. X
  1413. X`09    rewrite(4,iostat=ios)fd
  1414. X`09
  1415. X`09    close(unit=4)
  1416. X`09else
  1417. X`09    write(6,1001)crlf(:cl)//'Transfer failed.'//bell
  1418. X`09end if
  1419. X`09go to 4150
  1420. X
  1421. X
  1422. Xcccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
  1423. Vccc
  1424. X
  1425. X 4700`09continue`09`09!Upload
  1426. X`09area='upload'
  1427. X`09if (.not.approved_file_up) then
  1428. X`09    write(6,1001)crlf(:cl)//bell//
  1429. X`091`09'You are not yet approved for the upload section.'
  1430. X`09    write(6,1001)crlf(:cl)//'Sorry.'
  1431. X`09    return
  1432. X`09    end if
  1433. X`09if(reprint.or.(.not.ur.xpert)) then
  1434. X`09    reprint=.false.
  1435. X`09    call type_file('ubbs_files:`5B000000`5Dupload.areas')
  1436. X 4701`09    write(6,1001)crlf(:cl)//'Enter area of interest? `5Bexit`5D'
  1437. X`09else
  1438. X`09    write(6,1001)crlf(:cl)//'Area? '
  1439. X`09end if
  1440. X`09dummy=3`09    `09   `20
  1441. X`09call get_uplow_string(darea,dummy)
  1442. X`09istat = str$upcase(darea,darea)
  1443. X`09if(dummy.eq.0.or.darea.eq.'EXI') go to 4900
  1444. X`09if(darea.eq.'?') then
  1445. X`09    reprint=.true.
  1446. X`09    go to 4700
  1447. X`09    end if
  1448. X
  1449. X`09dummy=0
  1450. X`09if (lib$find_file('ubbs_files:`5B'//darea//'`5Dallow.up',
  1451. X`091   filename,dummy).ne.rms$_normal) then
  1452. X`09    write(6,1001)crlf(:cl)//
  1453. X`091`09'That is not a valid area.  Please try again'
  1454. X`09    reprint=.true.
  1455. X`09    go to 4700
  1456. X`09    end if
  1457. X`09write(6,1001)crlf(:cl)//'(A)scii, (B)inary, (H)elp, (E)xit? `5Bexit`5D'
  1458. X`09dummy=1
  1459. X`09call get_upcase_string(cdummy,dummy)
  1460. X`09if (cdummy.eq.'E'.or.dummy.eq.0) go to 4900
  1461. X`09if (cdummy.eq.'A') then
  1462. X`09    file_type = ascii
  1463. X`09    ftyp='Ascii '
  1464. X`09    fd.file_type='U'
  1465. X`09    binasc='.asc'
  1466. X`09else if (cdummy.eq.'B') then
  1467. X`09    file_type=binary
  1468. X`09    fd.file_type='V'
  1469. X`09    ftyp='Binary'
  1470. X`09    binasc='.bin'
  1471. X`09else if (cdummy.eq.'H') then
  1472. X`09    controlc_typed=.false.
  1473. X`09    istat=lbr$output_help(bbs_put_output,,
  1474. X`091`09'bbs_help file','ubbs_data:helplib',,bbs_get_input)
  1475. X`09    go to 4700
  1476. X`09else
  1477. X`09    write(6,1001)crlf(:cl)//'Invalid selection. Please try again'
  1478. X`09    go to 4700
  1479. X`09end if
  1480. X
  1481. X`09if(file_type.eq.binary) then
  1482. X`09    protocol=unknown
  1483. X`09    do while(protocol.eq.unknown)
  1484. X`09`09write(6,1001)crlf(:cl)//'Binary transfers must be by Xmodem,'
  1485. X`09`09write(6,1001)crlf(:cl)//'Ymodem or Kermit protocol.'
  1486. X`09`09write(6,1001)crlf(:cl)//
  1487. X`091`09    '(K)ermit or (X)modem/Ymodem protocol? `5Bexit`5D '
  1488. X`09`09dummy=1
  1489. X`09`09call get_upcase_string(cdummy,dummy)
  1490. X`09`09if(cdummy.eq.'E'.or.dummy.eq.0) go to 4900
  1491. X`09`09if(cdummy.eq.'K') protocol=kermit
  1492. +-+-+-+-+-+-+-+-  END  OF PART 8 +-+-+-+-+-+-+-+-
  1493.