home *** CD-ROM | disk | FTP | other *** search
/ ftp.barnyard.co.uk / 2015.02.ftp.barnyard.co.uk.tar / ftp.barnyard.co.uk / cpm / walnut-creek-CDROM / CPM / BBSING / BBS / XBBSV23.ARK / XBBS23UT.BAS < prev    next >
BASIC Source File  |  1986-09-14  |  8KB  |  182 lines

  1. 10 DEFINT A-Z:H$="######":H1$="##":LCK$="ABCDEF"
  2. 20 ON ERROR GOTO 900
  3. 30 DIM M$(16):CLS$=CHR$(26):SEP$="============================================="
  4. 40 PRINT CLS$
  5. 50 PRINT"   [XBBS] v2.3 Utility Program    Written by Robert Crump":PRINT
  6. 60 PRINT SEP$:PRINT"Whice drive do you wish to store your archived files on: ";:PRINT CHR$(7);:LINE INPUT A$:CY$=A$:GOSUB 840:A$=CY$
  7. 70 IF A$="" THEN 60 ELSE FF=INSTR("ABCD",A$):IF FF=0 THEN 60 ELSE A1$=A$+":"
  8. 80 PRINT SEP$:PRINT"Which drive are your files to be purged: ";:PRINT CHR$(7);:LINE INPUT B$:CY$=B$:GOSUB 840:B$=CY$
  9. 90 IF B$="" THEN 80 ELSE FF=INSTR("ABCD",B$):IF FF=0 THEN 80 ELSE A2$=B$+":"
  10. 100 IF A1$=A2$ THEN PRINT"Both source and destination files cannot reside on the same drive...re-select":GOTO 60
  11. 110 PRINT CLS$;:PRINT SEP$:T9=0
  12. 120 PRINT"[XBBS] v2.3 Utility Commands:":PRINT
  13. 130 PRINT"P ==> purge the message file."
  14. 140 PRINT"U ==> purge the users file."
  15. 150 PRINT"B ==> build a summary from msg. file."
  16. 160 PRINT"R ==> reset counters."
  17. 170 PRINT"E ==> return to cp/m."
  18. 180 PRINT SEP$
  19. 190 PRINT:PRINT"Command: ";:LINE INPUT C$:CY$=C$:GOSUB 840:C$=CY$
  20. 200 IF C$="" THEN 190 ELSE FF=INSTR("PUBRE",C$):IF FF=0 THEN 190
  21. 210 ON FF GOTO 220,1060,1420,1690,970
  22. 220 '***** PURGE MESSAGE FILE SECTION *****
  23. 230 PRINT CLS$;:PRINT"(MM/DD/YY)":PRINT"Enter todays date: ";:LINE INPUT D$
  24. 240 IF D$="" THEN 110 ELSE D1$=D$
  25. 250 PRINT:PRINT"Purging summary file..."
  26. 260 NAME A2$+"SUMMARY. " AS A2$+"SUMMARY.BAK"
  27. 270 OPEN"R",1,A2$+"SUMMARY.BAK",92
  28. 280 FIELD #1,24 AS SUN$,6 AS SUM$,2 AS SPR$,6 AS SUP$,21 AS SUB$,24 AS SFR$,9 AS SDT$
  29. 290 OPEN"R",2,A2$+"SUMMARY.$$$",92
  30. 300 FIELD #2,24 AS PUN$,6 AS PUM$,2 AS PPR$,6 AS PUP$,21 AS PUB$,24 AS PFR$,9 AS PDT$
  31. 310 SR=2
  32. 320 GET #1,SR:SN$=SUN$:SM$=SUM$:PV$=SPR$:PWD$=SUP$:SB$=SUB$:SFN$=SFR$:ZDT$=SDT$
  33. 330 IF EOF(1) THEN CLOSE #1,#2:GOTO 440
  34. 340 SM=VAL(SUM$):IF SM<>0 THEN 350 ELSE 430
  35. 350 PRINT SEP$:PRINT"Msg.#";SM;"  Date: ";ZDT$
  36. 360 PRINT"To: ";SN$
  37. 370 PRINT"From: ";SFN$
  38. 380 PRINT"Subject: ";SB$
  39. 390 GET #2,1:RS=VAL(PUN$):IF RS<2 THEN RS=2
  40. 400 LSET PUN$=STR$(RS+1):PUT #2,1
  41. 410 LSET PUN$=SN$:LSET PUM$=SM$:LSET PPR$=PV$:LSET PUP$=PWD$:LSET PUB$=SB$:LSET PFR$=SFN$:LSET PDT$=ZDT$
  42. 420 PUT #2,RS:SR=SR+1:GOTO 320
  43. 430 PRINT SEP$:PRINT"Deletion...":SR=SR+1:GOTO 320
  44. 440 PRINT SEP$:PRINT:PRINT"Purging Message File...":PRINT
  45. 450 NAME A2$+"MESSAGES. " AS A2$+"MESSAGES.BAK"
  46. 460 OPEN"R",1,A2$+"MESSAGES.BAK",64:FIELD #1,64 AS RR$
  47. 470 OPEN"R",2,A2$+"MESSAGES.$$$",64:FIELD #2,64 AS RA$
  48. 480 OPEN"R",3,A1$+D1$+".ARC",64:FIELD #3,64 AS RB$
  49. 490 RN=2
  50. 500 GET #1,RN:I=INSTR(RR$,"~"):LE=VAL(LEFT$(RR$,I-1))
  51. 510 J=INSTR(I+1,RR$,"~"):PA$=MID$(RR$,I+1,J-I-1)
  52. 520 J1=INSTR(J+1,RR$,"~"):PA1$=MID$(RR$,J+1,J1-J-1)
  53. 530 J2=INSTR(J1+1,RR$,"~"):PA2$=MID$(RR$,J1+1,J2-J1-1)
  54. 540 J3=INSTR(J2+1,RR$," "):PA3$=MID$(RR$,J2+1,J3-J2-1)
  55. 550 RN=RN+1:GET #1,RN:I=INSTR(RR$,"~"):EM=VAL(LEFT$(RR$,I-1))
  56. 560 J=INSTR(I+1,RR$,"~"):PA4$=MID$(RR$,I+1,J-I-1)
  57. 570 J1=INSTR(J+1,RR$,"~"):PA5$=MID$(RR$,J+1,J1-J-1)
  58. 580 IF EM<>0 THEN 590 ELSE EM$=LEFT$(RR$,I-1):GOTO 730
  59. 590 GET #2,1:MR=VAL(RA$):IF MR<2 THEN MR=2
  60. 600 RR2$=STR$(MR+2+LE):GOSUB 1000:PUT #2,1
  61. 610 RR2$=STR$(LE)+"~"+PA$+"~"+PA1$+"~"+PA2$+"~"+PA3$:GOSUB 1000:PUT #2,MR:MR=MR+1
  62. 620 RR2$=STR$(EM)+"~"+PA4$+"~"+PA5$+"~":GOSUB 1000:PUT #2,MR:MR=MR+1
  63. 630 PRINT SEP$:PRINT
  64. 640 PRINT"Msg.#";EM;  "Date: ";PA3$
  65. 650 PRINT"To: ";PA4$
  66. 660 PRINT"From: ";PA5$
  67. 670 PRINT"Subject: ";PA2$:PRINT
  68. 680 RN=RN+1
  69. 690 GET #1,RN:M1=M1+1
  70. 700 RR4$=LEFT$(RR$,62):PRINT RR4$:RR2$=RR4$:GOSUB 1000:PUT #2,MR
  71. 710 IF M1=LE THEN 720 ELSE RN=RN+1:MR=MR+1:GOTO 690
  72. 720 RN=RN+1:M1=0:GOTO 500
  73. 730 PRINT SEP$:GET #3,1:NR=VAL(RB$):IF NR<2 THEN NR=2
  74. 740 RR3$=STR$(NR+2+LE):GOSUB 1030:PUT #3,1
  75. 750 PRINT"Archiving message..."
  76. 760 RR3$=STR$(LE)+"~"+PA$+"~"+PA1$+"~"+PA2$+"~"+PA3$:GOSUB 1030:PUT #3,NR:NR=NR+1
  77. 770 RR3$=EM$+"~"+PA4$+"~"+PA5$+"~":GOSUB 1030:PUT #3,NR:NR=NR+1
  78. 780 RN=RN+1
  79. 790 GET #1,RN:M1=M1+1
  80. 800 RR3$=RR$:GOSUB 1030:PUT #3,NR
  81. 810 PUT #3,NR
  82. 820 IF M1=LE THEN 830 ELSE RN=RN+1:NR=NR+1:GOTO 790
  83. 830 RN=RN+1:M1=0:GOTO 500
  84. 840 '***** LOWER TO UPPER CONVERSION *****
  85. 850 FOR ZZ=1 TO LEN(CY$)
  86. 860 ZA=ASC(MID$(CY$,ZZ,1)):IF ZA<&H61 OR ZA>&H7A THEN 880
  87. 870 MID$(CY$,ZZ,1)=CHR$(ZA-&H20)
  88. 880 NEXT ZZ
  89. 890 RETURN
  90. 900 '***** ON ERROR TRAPPING ****
  91. 910 IF ERL=450 THEN PRINT"Drive error on archive select. Re-select.":RESUME 60
  92. 920 IF ERL=1230 THEN CLOSE #1,2:PRINT"User file defect. Modify with WS.":STOP
  93. 930 IF ERL=500 AND T9=1 THEN RESUME 1450 ELSE CLOSE #1,2,3:GOTO 110
  94. 940 IF ERL=1180 THEN RESUME 1340
  95. 950 IF ERL=1450 THEN RESUME 1460
  96. 960 IF ERL=1520 THEN CLOSE #1,2:GOTO 110
  97. 970 '**** RETURN TO CPM ****
  98. 980 SYSTEM
  99. 990 '***** MESSAGE FILE LSET *****
  100. 1000 RL=64
  101. 1010 LSET RA$=LEFT$(RR2$+SPACE$(RL-2),RL-2)+CHR$(13)+CHR$(10)
  102. 1020 RETURN
  103. 1030 RL=64
  104. 1040 LSET RB$=LEFT$(RR3$+SPACE$(RL-2),RL-2)+CHR$(13)+CHR$(10)
  105. 1050 RETURN
  106. 1060 '***** USER PURGE SECTION *****
  107. 1070 PRINT CLS$;:PRINT SEP$
  108. 1080 PRINT"Users with password of ";LCK$;" will be purged."
  109. 1090 PRINT"Users below entered date will be purged.":PRINT SEP$
  110. 1100 PRINT:PRINT"(DD-MMM-YY)":PRINT"Enter deletion date: ";:LINE INPUT D$:MN=1
  111. 1110 READ MO$
  112. 1120 IF MO$<>MID$(D$,4,3) THEN MN=MN+1:GOTO 1110
  113. 1130 MN1=MN:RESTORE
  114. 1140 NAME A2$+"USERS. " AS A2$+"USERS.BAK"
  115. 1150 OPEN"R",1,A2$+"USERS.BAK",64:FIELD #1,64 AS UR$:UR=2
  116. 1160 OPEN"R",2,A2$+"USERS.$$$",64:FIELD #2,64 AS UR1$
  117. 1170 GET #1,UR
  118. 1180 I=INSTR(UR$,"~"):UN=VAL(LEFT$(UR$,I-1))
  119. 1190 I1=INSTR(I+1,UR$,"~"):NM$=MID$(UR$,I+1,I1-I-1)
  120. 1200 I2=INSTR(I1+1,UR$,"~"):PWD$=MID$(UR$,I1+1,I2-I1-1)
  121. 1210 I3=INSTR(I2+1,UR$,"~"):DTE$=MID$(UR$,I2+1,I3-I2-1)
  122. 1220 I4=INSTR(I3+1,UR$,"~"):MH=VAL(MID$(UR$,I3+1,I4-I3-1))
  123. 1230 I5=INSTR(I4+1,UR$,"~"):CT$=MID$(UR$,I4+1,I5-I4-1)
  124. 1240 MO=1
  125. 1250 READ MO1$
  126. 1260 IF MO1$<>MID$(DTE$,4,3) THEN MO=MO+1:GOTO 1250
  127. 1270 C=(MN-MO):IF C<0 THEN MN=MN+12:GOTO 1270:ELSE D=VAL(LEFT$(DTE$,2)):E=VAL(LEFT$(D$,2))
  128. 1280 DAY=30:IF C=>1 THEN DAY=DAY*C:MAX=DAY+E:ELSE MAX=E:C=0
  129. 1290 IF (MAX-D)=>30 OR PWD$=LCK$ THEN UR=UR+1:MN=MN1:RESTORE:GOTO 1170
  130. 1300 GET #2,1:UR1=VAL(UR1$):IF UR1<2 THEN UR1=2
  131. 1310 RL=63:UR2$=STR$(UR1+1):GOSUB 1380:PUT #2,1
  132. 1320 PRINT SEP$:PRINT"Issuing new user #";UR1;"to ";NM$
  133. 1330 GOSUB 1350:PUT #2,UR1:UR=UR+1:RESTORE:MN=MN1:GOTO 1170
  134. 1340 CLOSE #1,#2:GOTO 110
  135. 1350 '***** USER FILE LSET *****
  136. 1360 RL=63
  137. 1370 UR2$=STR$(UR1)+"~"+NM$+"~"+PWD$+"~"+DTE$+"~"+STR$(MH)+"~"+CT$+"~"
  138. 1380 LSET UR1$=LEFT$(UR2$+SPACE$(RL-2),RL-2)+CHR$(13)+CHR$(10)
  139. 1390 RETURN
  140. 1400 '***** DATA SET *****
  141. 1410 DATA JAN,FEB,MAR,APR,MAY,JUN,JUL,AUG,SEP,OCT,NOV,DEC
  142. 1420 '***** BUILD A SUMMARY FROM MSG. FILE *****
  143. 1430 T9=1:PRINT CLS$;:PRINT"(MM/DD/YY)":PRINT"Enter todays date: ";:LINE INPUT D$
  144. 1440 IF D$="" THEN 110 ELSE D1$=D$:GOTO 440
  145. 1450 CLOSE #1,2,3:KILL A2$+"SUMMARY. "
  146. 1460 PRINT:PRINT"Creating new summary file..."
  147. 1470 OPEN"R",1,A2$+"SUMMARY.$$$",92
  148. 1480 FIELD #1,24 AS SUN$,6 AS SUM$,2 AS SPR$,6 AS SUP$,21 AS SUB$,24 AS SFR$,9 AS SDT$
  149. 1490 OPEN"R",2,A2$+"MESSAGES.$$$",64
  150. 1500 FIELD #2,64 AS RA$
  151. 1510 RN=2
  152. 1520 GET #2,RN:I=INSTR(RA$,"~"):LE=VAL(LEFT$(RA$,I-1))
  153. 1530 J=INSTR(I+1,RA$,"~"):PA$=MID$(RA$,I+1,J-I-1)
  154. 1540 J1=INSTR(J+1,RA$,"~"):PA1$=MID$(RA$,J+1,J1-J-1)
  155. 1550 J2=INSTR(J1+1,RA$,"~"):PA2$=MID$(RA$,J1+1,J2-J1-1)
  156. 1560 J3=INSTR(J2+1,RA$," "):PA3$=MID$(RA$,J2+1,J3-J2-1)
  157. 1570 RN=RN+1:GET #2,RN:I=INSTR(RA$,"~"):EM=VAL(LEFT$(RA$,I-1))
  158. 1580 J=INSTR(I+1,RA$,"~"):PA4$=MID$(RA$,I+1,J-I-1)
  159. 1590 J1=INSTR(J+1,RA$,"~"):PA5$=MID$(RA$,J+1,J1-J-1)
  160. 1600 PRINT SEP$
  161. 1610 PRINT"Message #";EM;"  Date:";PA3$
  162. 1620 PRINT"To: ";PA4$
  163. 1630 PRINT"From: ";PA5$
  164. 1640 PRINT"Subject: ";PA2$
  165. 1650 GET #1,1:SR=VAL(SUN$):IF SR<2 THEN SR=2
  166. 1660 LSET SUN$=STR$(SR+1):PUT #1,1
  167. 1670 LSET SUN$=PA4$+"~":LSET SUM$=STR$(EM):LSET SPR$=PA$:LSET SUP$=PA1$:LSET SUB$=PA2$+"~":LSET SFR$=PA5$+"~":LSET SDT$=PA3$
  168. 1680 PUT #1,SR:RN=RN+LE+1:GOTO 1520
  169. 1690 '***** COUNTER RESET *****
  170. 1700 PRINT CLS$;:
  171. 1710 INPUT"Caller count? ",A
  172. 1720 INPUT"Active Msg. count? ",B
  173. 1730 INPUT"High Msg. count? ",C
  174. 1740 OPEN"R",1,A2$+"COUNTERS. "+CHR$(160)+" ",12
  175. 1750 FIELD #1,4 AS CAL$,4 AS MSG$,4 AS MNU$
  176. 1760 LSET CAL$=MKI$(A):LSET MSG$=MKI$(B):LSET MNU$=MKI$(C)
  177. 1770 PUT #1,1
  178. 1780 CLOSE #1:GOTO 110
  179. S CAL$,4 AS MSG$,4 AS MNU$
  180. 1760 LSET CAL$=MKI$(A):LSET MSG$=MKI$(B):LSET MNU$=MKI$(C)
  181. 1770 PUT #1,1
  182. 1