home *** CD-ROM | disk | FTP | other *** search
/ Oakland CPM Archive / oakcpm.iso / cpm / apple / binhex.bas < prev    next >
Encoding:
BASIC Source File  |  1984-12-10  |  19.2 KB  |  462 lines
  1. Here is the BASIC version of BinHex, a program for the Mac that converts
  2. resource/data files into mailable .Hex files and back.  Use it to convert
  3. BinHex.Hex (which follows in my next message)
  4.  
  5. ------------------------- C U T   H E R E -------------------------
  6. 10 'BinHex version 3.0.0 - By William B. Davis, Jr {CIS 71505,410}
  7. 20 'with modifications by     Bob VanBurkleo {CIS 74435,1373}
  8. 30 'using subroutines by:
  9. 40 '     Dennis Brothers of Brothers Associates {CIS 70065,172}
  10. 50 '     Ronald H. Nicholson, Jr {CIS 71505,410}
  11. 60 'Permission is hereby granted for personal, non-commercial reproduction
  12. 70 'and use of this program, provided that this notice is included.
  13. 100 CLEAR,24000
  14. 110 CLEAR:DEFINT P:DIM PARAMLIST%(39),RECT%(5),BACKPATTERN%(4),GETFILEINFOCODE%(25)
  15. 120 DIM SETFILEINFOCODE%(25),P(89),DBUF%(256),VBUF%(266)
  16. 130 X255%=255:LFR=0:LFD=0:RFN=0
  17. 140 A=0:BOX=0:BX=0:BY=0:TRUE=-1:FALSE=0:CHOICE=0:CKSUM%=0:COUNT=0:E=0
  18. 150 FILE=0:FILEINFO!=0:FL=0:LF=0:FP!=0:I=0:LP=0:P=0:PARAM!=0:TR=0:PX=0:PY=0
  19. 160 R=0:RC=0:RF=0:RN=0:RW=0:RX=0:S=0:SETFILEINFO!=0:GETFILEINFO!=0:X=0:X9=0:Y=0:XX%=0
  20. 170 A$="":BF$="":D$="":E$="":DD$="":F$="":FT$="":HF$="":HX$="":RET$="":S$="":TEXT$="":FILE.EXISTS=0
  21. 180 TYPEAPPL$="":X$="":XX$=""
  22. 1000 WIDTH "SCRN:",255
  23. 1010 WHILE TRUE
  24. 1020    GOSUB 8000:CALL SHOWCURSOR
  25. 1030    RECT%(0)=2:RECT%(1)=10:RECT%(2)=275:RECT%(3)=475:GOSUB 7100
  26. 1040    RECT%(0)=5:RECT%(1)=13:RECT%(2)=272:RECT%(3)=472:GOSUB 7200
  27. 1050    CALL TEXTFONT(0):CALL TEXTSIZE(12)
  28. 1060    CALL TEXTMODE(1):CALL TEXTFACE(8)
  29. 1070    CALL MOVETO (45,20)
  30. 1080    PRINT"BinHex -- Hex to binary/Binary to hex file conversion"
  31. 1090    CALL MOVETO(140,40):CALL TEXTFACE(0)
  32. 1100    CALL TEXTFONT(1):CALL TEXTSIZE(9)
  33. 1110    PRINT"          Version 3.0.0 - Data & Resource Files";
  34. 1120    CALL MOVETO(35,260)
  35. 1130    PRINT"Copyright ";CHR$(169);"1984 by Calypso! Software ";
  36. 1140    PRINT"- May be reproduced for non-commercial use only.";
  37. 1150    CALL TEXTFONT(0):CALL TEXTSIZE(12)
  38. 1160    CALL MOVETO (120,68):PRINT"Click on the desired conversion method:";
  39. 1170    RESTORE 1200:GOSUB 6000
  40. 1180    ON CHOICE GOSUB 3000,2000,1500,1600
  41. 1185 GOTO 110
  42. 1190 WEND:STOP
  43. 1200 DATA 75,90,"Application document --> Upload format document"
  44. 1210 DATA 75,130,"Upload format document --> Application document"
  45. 1220 DATA 75,170,"Quit BinHex and return to the Macintosh Desktop"
  46. 1230 DATA 75,210,"Quit BinHex and return to Microsoft BASIC"
  47. 1240 DATA -1,-1,"Dummy end of list"
  48. 1500 GOSUB 8000
  49. 1510 RECT%(0)=100:RECT%(1)=100:RECT%(2)=150:RECT%(3)=400:GOSUB 7100
  50. 1520 RECT%(0)=103:RECT%(1)=103:RECT%(2)=147:RECT%(3)=397:GOSUB 7200
  51. 1530 CALL MOVETO(120,130):PRINT"Returning to Macintosh DeskTop....";
  52. 1540 SYSTEM
  53. 1600 CLS:CALL TEXTFONT(1):CALL TEXTSIZE(12)
  54. 1610 CALL TEXTMODE(0):CALL TEXTFACE(0)
  55. 1620 PRINT"Entering MS-BASIC Command mode....":END
  56. 1630 '--------------------------------------------------------
  57. 1640 '"             Hex ---> Binary conversion procedure
  58. 1650 '--------------------------------------------------------
  59. 2000 CHOICE=1
  60. 2010 WHILE CHOICE=1:GOSUB 8000:ON ERROR GOTO 0
  61. 2020 CALL TEXTMODE(1):CALL TEXTFACE(8)
  62. 2030 RECT%(0)=32:RECT%(1)=2:RECT%(2)=200:RECT%(3)=480:GOSUB 7100
  63. 2040 RECT%(0)=35:RECT%(1)=5:RECT%(2)=197:RECT%(3)=477:GOSUB 7200
  64. 2050 CALL MOVETO(15,52)
  65. 2060 PRINT "Convert Upload document (hex) to an Application document";
  66. 2070 CALL TEXTFACE(32):CALL MOVETO (15,73)
  67. 2080 PRINT "Enter name of Upload Document to convert FROM (Press RETURN to cancel):";
  68. 2090 CALL MOVETO(15,153)
  69. 2100 PRINT "Enter name of Application Document to CREATE (RETURN key skips back):";
  70. 2110 RECT%(0)=80:RECT%(1)=15:RECT%(2)=105:RECT%(3)=450:GOSUB 7000
  71. 2120 RECT%(0)=160:RECT%(1)=15:RECT%(2)=185:RECT%(3)=450:GOSUB 7000
  72. 2130 BX=20:BY=95:GOSUB 7500:HF$=RET$:IF HF$="" THEN RETURN
  73. 2140 FILE.EXISTS=TRUE
  74. 2150 ON ERROR GOTO 3600:OPEN"I",1,HF$
  75. 2160 CLOSE:IF NOT FILE.EXISTS THEN 2000
  76. 2170 BX=20:BY=175:GOSUB 7500:BF$=RET$:IF BF$="" THEN 2000
  77. 2180 OPEN"I",1,HF$,1:OPEN"O",2,BF$
  78. 2185 F$=HF$:GOSUB 4580:GOSUB 4000:LF=LFD
  79. 2190 '       Read in lines from file & ignore anything until the 
  80. 2200 '       Type/Creator header information is encountered.
  81. 2210 CKSUM%=0
  82. 2220 LINE INPUT #1,D$:'"   Prime the pump....
  83. 2230 WHILE LEFT$(D$,1)<>"#" AND NOT EOF(1)
  84. 2240    LINE INPUT #1,D$
  85. 2250 WEND
  86. 2260 '     if we reach this point (1) we have found the header, of the form
  87. 2270 '     #TYPECRTR where TYPE is 4 byte type code & CRTR is 4 byte 
  88. 2280 '     creator code; or (2) we have reached EOF of hex file.
  89. 2290 WHILE NOT EOF(1)
  90. 2300    TYPEAPPL$=MID$(D$,2,8)
  91. 2310    GOSUB 8000
  92. 2320    RECT%(0)=50:RECT%(1)=100:RECT%(2)=200:RECT%(3)=400
  93. 2330    CALL PENNORMAL:GOSUB 7000
  94. 2340    RECT%(0)=53:RECT%(1)=103:RECT%(2)=197:RECT%(3)=397
  95. 2350    CALL PENSIZE(2,2):GOSUB 7000:CALL PENNORMAL
  96. 2360    CALL MOVETO(110,80):CALL TEXTFACE(0):CALL TEXTMODE(1)
  97. 2370    PRINT "TYPE of new file is................:";MID$(TYPEAPPL$,1,4)
  98. 2380    CALL MOVETO(110,95)
  99. 2390    PRINT "CREATOR of new file is..........:";MID$(TYPEAPPL$,5,4)
  100. 2400    CALL MOVETO(110,110)
  101. 2410    PRINT USING "Length of new file will be approx : ###.##K";(LOF(1)/2)/1024;
  102. 2420    CALL MOVETO(110,175)
  103. 2430    PRINT "Conversion in process - Please stand by...."
  104. 2440    CALL TEXTMODE(0)
  105. 2450    F$=BF$:GOSUB 4660:GOSUB 4200:'"   Set type and creator of file
  106. 2460    LINE INPUT #1,D$
  107. 2470    IF LEFT$(D$,12)="***DATA FORK" THEN LINE INPUT #1,D$:CALL MOVETO (110,140):PRINT BF$;": a Data File"
  108. 2475 IF LEFT$(D$,11)="***RESOURCE" THEN CALL MOVETO(110,140):PRINT BF$;": a Resource File":GOSUB 21000:GOTO 2540
  109. 2480    WHILE NOT EOF(1)  AND LEFT$(D$,14)<>"***END OF DATA" 
  110. 2490            GOSUB 2800:'  Convert string to binary
  111. 2500            LINE INPUT #1,D$
  112. 2510    WEND
  113. 2520    IF NOT EOF(1) THEN LINE INPUT #1,D$:'get checksum if available
  114. 2525 GOTO 2540
  115. 2530 WEND
  116. 2540 CLOSE:GOSUB 8000
  117. 2550 RECT%(0)=30:RECT%(1)=80:RECT%(2)=220:RECT%(3)=410:GOSUB 7100
  118. 2560 RECT%(0)=33:RECT%(1)=83:RECT%(2)=217:RECT%(3)=407:GOSUB 7200
  119. 2570 CALL MOVETO (100,55):CALL TEXTMODE(1)
  120. 2580 PRINT "Conversion of upload format document to";
  121. 2590 CALL MOVETO(100,70)
  122. 2600 PRINT "application document has been completed!";
  123. 2610 CALL MOVETO(140,100)
  124. 2620 IF LEFT$(D$,12)="***CHECKSUM:" THEN PRINT "Checksum in file: ";MID$(D$,13,2);
  125. 2630 IF LEFT$(D$,12)<>"***CHECKSUM:" THEN PRINT "No checksum present in file...";
  126. 2640 XX$=HEX$(CKSUM%):IF LEN(XX$)<2 THEN XX$="0"+XX$
  127. 2650 CALL MOVETO (140,115):PRINT "Calculated Checksum: ";XX$;
  128. 2660 BEEP:RESTORE 2690:GOSUB 6000:CALL TEXTMODE(0)
  129. 2670 WEND:' of the WHILE CHOICE=1
  130. 2680 RETURN:' if CHOICE=2
  131. 2690 DATA 130,155,"Convert another upload document"
  132. 2700 DATA 130,180,"Return to Main Conversion menu"
  133. 2710 DATA -1,-1,"dummy end of list"
  134. 2720 '----- Loop to break down input line into byte-pairs & convert -----
  135. 2800 FOR I=1 TO LEN(D$) STEP 2
  136. 2810    XX%=VAL("&H"+MID$(D$,I,2)):CKSUM%=(CKSUM%+XX%) AND 255
  137. 2820    PRINT #2,CHR$(XX%);
  138. 2830 NEXT I:RETURN
  139. 2840 '-------------------------------------------------------
  140. 2850 '               Binary ---> Hex conversion procedure
  141. 2860 '-------------------------------------------------------
  142. 3000 CHOICE=1
  143. 3010 WHILE CHOICE=1:GOSUB 8000
  144. 3020 ON ERROR GOTO 0:CALL TEXTMODE(1):CALL TEXTFACE(8)
  145. 3030 RECT%(0)=32:RECT%(1)=2:RECT%(2)=200:RECT%(3)=480:GOSUB 7100
  146. 3040 RECT%(0)=35:RECT%(1)=5:RECT%(2)=197:RECT%(3)=477:GOSUB 7200
  147. 3050 CALL MOVETO(15,52)
  148. 3060 PRINT "Convert Application document to an Upload document (hex)";
  149. 3070 CALL TEXTFACE(32):CALL MOVETO (15,73)
  150. 3080 PRINT "Enter name of Application Document to convert FROM (Press RETURN to cancel):";
  151. 3090 CALL MOVETO(15,153)
  152. 3100 PRINT "Enter name of Upload Document to CREATE (RETURN key skips back):";
  153. 3110 RECT%(0)=80:RECT%(1)=15:RECT%(2)=105:RECT%(3)=450:GOSUB 7000
  154. 3120 RECT%(0)=160:RECT%(1)=15:RECT%(2)=185:RECT%(3)=450:GOSUB 7000
  155. 3130 BX=20:BY=95:GOSUB 7500:BF$=RET$:IF BF$="" THEN RETURN
  156. 3140 FILE.EXISTS=TRUE
  157. 3150 ON ERROR GOTO 3600:OPEN"I",1,BF$
  158. 3160 ON ERROR GOTO 0: CLOSE:IF NOT FILE.EXISTS THEN 3000
  159. 3170 BX=20:BY=175:GOSUB 7500:HF$=RET$
  160. 3180 OPEN"O",2,HF$
  161. 3190 F$=BF$:GOSUB 4580:GOSUB 4000:LF=LFD+LFR
  162. 3200 CLS:CALL TEXTFACE(0)
  163. 3210 PRINT "LENGTH of Application document is:";LF;" bytes (characters)"
  164. 3220 PRINT "TYPE of Application document is: ";LEFT$(TYPEAPPL$,4)
  165. 3230 PRINT "CREATOR of Application document is: ";RIGHT$(TYPEAPPL$,4)
  166. 3235 PRINT "DOCUMENT is a ";:IF LFD=0 THEN PRINT "Resource File":ELSE PRINT "Data File"
  167. 3240 PRINT:CALL TEXTFONT(4):CALL TEXTSIZE(9)
  168. 3250 PRINT "<---Hex data being output-------------------------------------->  ";
  169. 3260 PRINT"Processed/Total"
  170. 3270 CKSUM%=0:COUNT=0
  171. 3275 IF LFD=0 THEN GOSUB 22000:GOTO 3380
  172. 3280 PRINT #2,"#";TYPEAPPL$:PRINT #2,"***DATA FORK"
  173. 3285 OPEN "R",1,BF$,1:FIELD 1,1 AS D$
  174. 3290 FOR I = 1 TO LFD
  175. 3300            GET 1,I
  176. 3310            DD$=HEX$(ASC(D$)):IF LEN(DD$)<2 THEN DD$="0"+DD$
  177. 3320            CKSUM%=(CKSUM%+ASC(D$)) AND 255
  178. 3330            PRINT #2,DD$;:PRINT DD$;
  179. 3340            COUNT=COUNT+1
  180. 3350            IF COUNT=32 THEN COUNT=0:PRINT #2,"":PRINT USING " ######_/";I;:PRINT LFD
  181. 3360 NEXT I
  182. 3370 IF COUNT<32 THEN PRINT #2,""
  183. 3380 PRINT #2,"***END OF DATA"
  184. 3390 XX$=HEX$(CKSUM%):IF LEN(XX$)<2 THEN XX$="0"+XX$
  185. 3400 PRINT #2,"***CHECKSUM:";XX$
  186. 3410 CLOSE:CALL TEXTFONT(0):CALL TEXTSIZE(12)
  187. 3420 RECT%(0)=30:RECT%(1)=80:RECT%(2)=220:RECT%(3)=410:GOSUB 7100
  188. 3430 RECT%(0)=33:RECT%(1)=83:RECT%(2)=217:RECT%(3)=407:GOSUB 7200
  189. 3440 CALL MOVETO(90,70):CALL TEXTMODE(1)
  190. 3450 PRINT "Conversion of Application document to an";
  191. 3460 CALL MOVETO (90,85)
  192. 3470 PRINT "Upload format document has been completed!";
  193. 3480 BEEP:RESTORE 3510:GOSUB 6000
  194. 3490 WEND: '  of the WHILE CHOICE=1
  195. 3500 RETURN: ' if CHOICE=2
  196. 3510 DATA 110,120,"Convert another Application document"
  197. 3520 DATA 110,160,"Return to Main Conversion Menu"
  198. 3530 DATA -1,-1,"dummy end of list"
  199. 3540 '------ Subroutine to handle file-not-found condition ------
  200. 3600 RECT%(0)=75:RECT%(1)=100:RECT%(2)=165:RECT%(3)=400:GOSUB 7100
  201. 3610 RECT%(0)=79:RECT%(1)=103:RECT%(2)=162:RECT%(3)=397:GOSUB 7200
  202. 3620 CALL MOVETO(160,110):PRINT"That document does not exist!";
  203. 3630 BEEP:BEEP:RESTORE 3640:GOSUB 6000
  204. 3640 DATA 150,130,"<--Click here to select another file"
  205. 3650 DATA -1,-1,"Dummy end of File not found list"
  206. 3660 FILE.EXISTS=FALSE:RESUME NEXT
  207. 3670 '------------------------------------------------------------
  208. 3680 '   _GetFileInfo --  Subroutine to get type and application of a file
  209. 3690 '------------------------------------------------------------
  210. 4000 FL=LEN(F$)
  211. 4010 F$=CHR$(FL)+F$
  212. 4020 FP!=VARPTR(F$)
  213. 4030 PARAM!=VARPTR(PARAMLIST%(0))
  214. 4040 FOR I=0 TO 79: POKE PARAM!+I,0: NEXT I
  215. 4050 POKE PARAM!+19,PEEK(FP!+2)
  216. 4060 POKE PARAM!+20,PEEK(FP!+3)
  217. 4070 POKE PARAM!+21,PEEK(FP!+4)
  218. 4080 GETFILEINFO!=VARPTR(GETFILEINFOCODE%(0))
  219. 4090 CALL GETFILEINFO!(PARAM!)
  220. 4100 TYPEAPPL$ = ""
  221. 4110 FOR I = 1 TO 8
  222. 4120 TYPEAPPL$ = TYPEAPPL$ + CHR$(PEEK(PARAM!+31+I))
  223. 4130 NEXT I
  224. 4135 LFD=PEEK(PARAM!+56)*256+PEEK(PARAM!+57)
  225. 4136 LFR=PEEK(PARAM!+66)*256+PEEK(PARAM!+67)
  226. 4140 RETURN
  227. 4150 '-------------------------------------------------------------
  228. 4160 '   _SetFileInfo  --  Subroutine to set type and application of a file
  229. 4170 '-------------------------------------------------------------
  230. 4200 FL=LEN(F$)
  231. 4210 F$=CHR$(FL)+F$
  232. 4220 PARAM!=VARPTR(PARAMLIST%(0))
  233. 4230 FP!=VARPTR(F$)
  234. 4240 FOR I=0 TO 79: POKE PARAM!+I,0: NEXT I
  235. 4250 POKE PARAM!+19,PEEK(FP!+2)
  236. 4260 POKE PARAM!+20,PEEK(FP!+3)
  237. 4270 POKE PARAM!+21,PEEK(FP!+4)
  238. 4280 GETFILEINFO!=VARPTR(GETFILEINFOCODE%(0))
  239. 4290 CALL GETFILEINFO!(PARAM!)
  240. 4300 FOR I=1 TO LEN(TYPEAPPL$)
  241. 4310 POKE PARAM!+31+I,ASC(MID$(TYPEAPPL$,I,1))
  242. 4320 NEXT I
  243. 4330 SETFILEINFO!=VARPTR(SETFILEINFOCODE%(0))
  244. 4340 CALL SETFILEINFO!(PARAM!)
  245. 4350 RETURN
  246. 4360 '-----------------------------------------------------------
  247. 4370 '                Setup Machine Language Toolkit calls
  248. 4380 '-----------------------------------------------------------
  249. 4560 '               Set up  _GetFileInfo  ToolKit call
  250. 4580 RESTORE 4610:I=0
  251. 4590 READ A:GETFILEINFOCODE%(I)=A
  252. 4600 I=I+1:IF A<>-1 THEN GOTO 4590
  253. 4605 RETURN
  254. 4610 DATA &H4E56, &HFFF8, &H48EE, &H0101, &HFFF8, &H206E, &H0008, &HA00C
  255. 4620 DATA &H4CEE, &H0101, &HFFF8, &H4E5E, &H4E75
  256. 4630 DATA -1
  257. 4640 '               Set up _SetFileInfo Toolkit call
  258. 4660 RESTORE 4700:I=0
  259. 4670 READ A:SETFILEINFOCODE%(I)=A
  260. 4680 I=I+1:IF A<>-1 THEN GOTO 4670
  261. 4690 RETURN
  262. 4700 DATA &H4E56, &HFFF8, &H48EE, &H0101, &HFFF8, &H206E, &H0008, &HA00D
  263. 4710 DATA &H4CEE, &H0101, &HFFF8, &H4E5E, &H4E75
  264. 4720 DATA -1
  265. 4730 '----------------------------------------------------------
  266. 4740 '                   Pseudo-Dialog-Box subroutine
  267. 4750 '----------------------------------------------------------
  268. 6000 BOX=0:READ X,Y,TEXT$
  269. 6010 WHILE X<>-1
  270. 6020    BOX=BOX+1:CHECKBOX(BOX,1)=X:CHECKBOX(BOX,2)=Y
  271. 6030    CHECKTEXT$(BOX)=TEXT$:READ X,Y,TEXT$
  272. 6040 WEND
  273. 6050 FOR I=1 TO BOX
  274. 6060    CIRCLE(CHECKBOX(I,1),CHECKBOX(I,2)),7
  275. 6070    CIRCLE(CHECKBOX(I,1),CHECKBOX(I,2)),5
  276. 6080    CALL MOVETO(CHECKBOX(I,1)+15,CHECKBOX(I,2)+5)
  277. 6090    PRINT CHECKTEXT$(I);
  278. 6100 NEXT I
  279. 6110 CHOICE=0
  280. 6120 WHILE CHOICE=0
  281. 6130    WHILE MOUSE(0)<>-1:WEND
  282. 6140    PX=MOUSE(1):PY=MOUSE(2)
  283. 6150    FOR I=1 TO BOX
  284. 6160            P=SQR((PX-CHECKBOX(I,1))^2+(PY-CHECKBOX(I,2))^2)
  285. 6170            IF P<5 THEN CHOICE=I:I=BOX :' once choice found, stop loop.
  286. 6180    NEXT I
  287. 6190 WEND
  288. 6200  FOR I=0 TO 4
  289. 6210    CIRCLE(CHECKBOX(CHOICE,1),CHECKBOX(CHOICE,2)),I
  290. 6220 NEXT I
  291. 6230 WHILE MOUSE(0)<>1:WEND:RETURN
  292. 6240 '---------------------------------------------------
  293. 6250 '                Routines used to draw Dialog boxes
  294. 6260 '---------------------------------------------------
  295. 7000 CALL ERASERECT(VARPTR(RECT%(0)))
  296. 7010 CALL FRAMERECT(VARPTR(RECT%(0)))
  297. 7020 RETURN
  298. 7100 CALL PENNORMAL:GOSUB 7000:RETURN
  299. 7200 CALL PENSIZE(2,2):GOSUB 7000:CALL PENNORMAL:RETURN
  300. 7210 '---------------------------------------------------------
  301. 7220 '     Controlled Keyboard input routine, with cursor
  302. 7230 '---------------------------------------------------------
  303. 7500 A$="":RET$=""
  304. 7510 CALL MOVETO(BX,BY):CALL TEXTMODE(0)
  305. 7520 CALL PENSIZE(1,1):CALL SHOWPEN
  306. 7530 CALL OBSCURECURSOR:CALL LINE(0,-10)
  307. 7540 WHILE A$<>CHR$(13) AND A$<> CHR$(9) AND A$<>CHR$(3)
  308. 7550    A$=INKEY$
  309. 7560    IF A$<>"" AND A$>CHR$(31) THEN GOSUB 7630
  310. 7570    IF A$=CHR$(8) AND LEN(RET$)>0 THEN GOSUB 7660
  311. 7580    IF A$=CHR$(8) AND LEN(RET$)=0 THEN GOSUB 7690
  312. 7590    IF LEN(RET$)>65 THEN BEEP:A$=CHR$(13)
  313. 7600 WEND
  314. 7610 CALL MOVETO(BX,BY):PRINT RET$;" ";:RETURN
  315. 7620 '-------- Handle normal input of letter ASCII 32-255 ------------
  316. 7630 RET$=RET$+A$:CALL LINE(0,10)
  317. 7640 PRINT A$;:CALL LINE(0,-10):RETURN
  318. 7650 '------- Hande Backspacing with input length >0 ----------------
  319. 7660 CALL MOVETO(BX,BY):RET$=LEFT$(RET$,LEN(RET$)-1)
  320. 7670 PRINT RET$;:CALL LINE(0,-10):RETURN
  321. 7680 '------- Handle Backspacing when input length goes to 0 ------
  322. 7690 CALL MOVETO(BX,BY):PRINT"   ";:CALL LINE(0,-10):
  323. 7700 CALL MOVETO (BX,BY):CALL LINE(0,-10):RETURN
  324. 7710 '------- Change Window Background pattern to grey -------
  325. 8000 FOR I=0 TO 4:BACKPATTERN%(I)=&HAA55:NEXT I
  326. 8010 CALL BACKPAT(VARPTR(BACKPATTERN%(0))):CLS
  327. 8020 FOR I=0 TO 4:BACKPATTERN%(I)=0:NEXT I
  328. 8030 CALL BACKPAT(VARPTR(BACKPATTERN%(0))):RETURN
  329. 10000 ' Open Resource Fork For E$
  330. 10010 IF P(0)<>&H41FA THEN GOSUB 15000
  331. 10020 P(8)=&HA20A:' Open RF
  332. 10030 Y=VARPTR(P(42)):'length of file name
  333. 10040 POKE Y,LEN(E$)
  334. 10050 FOR I=1 TO LEN(E$):POKE (Y+I),ASC(MID$(E$,I,1)):NEXT I
  335. 10060 P(25)=INT(Y/65536!):GOSUB 20000
  336. 10070 P(26)=X:'lsw of name
  337. 10080 P(27)=0:'volume
  338. 10090 P(29)=RW:'version and R/W Permission
  339. 10100 P(30)=0'Nil-> default volume buffer msw
  340. 10110 P(31)=0:'Nil-> default volume buffer lsw
  341. 10115 IF RW=1 THEN GOTO 10160
  342. 10120 Y=VARPTR(VBUF%(0))
  343. 10130 P(30)=INT(Y/65536!):GOSUB 20000:' volume buffer msw
  344. 10140 P(31)=X:'volume buffer lsw
  345. 10160 X=VARPTR(P(0)):CALL X:'open the Fork
  346. 10170 RC=P(16):'return code
  347. 10180 RFN=P(28):'reference number
  348. 10190 RETURN
  349. 10500 ' Close RF at RefNum
  350. 10510 IF P(0)<>&H41FA THEN GOSUB 15000
  351. 10520 P(8)=&HA201:'Close RF byte
  352. 10530 P(28)=RFN:'Refnum
  353. 10540 GOTO 10030 :'insert into main loop
  354. 11000 'Set up for Write RF
  355. 11010 IF P(0)<>&H41FA THEN GOSUB 15000
  356. 11020 P(8)=&HA203:'Write byte
  357. 11030 P(39)=0:' offset msw
  358. 11033 Y=VARPTR(VBUF%(0)):P(30)=INT(Y/65536!):GOSUB 20000
  359. 11036 P(31)=X
  360. 11040 P(40)=0:'offset lsw
  361. 11050 TR=VARPTR(DBUF%(0))
  362. 11060 P(32)=INT(TR/65535!):Y=TR:GOSUB 20000
  363. 11080 P(33)=X:'buffer
  364. 11090 P(34)=0:'count high
  365. 11100 P(35)=1:'count low
  366. 11110 P(38)=1:'mode as absolute offset
  367. 11120 RETURN
  368. 12000 'Write RF (hex->bin)
  369. 12010 IF EOF (1) THEN GOTO 12990:' return
  370. 12020 E=0: IF EOF(1) THEN CLS:PRINT "Hex File Error":GOTO 12990
  371. 12030 INPUT #1,D$
  372. 12040 IF MID$(D$,1,6)="***END" THEN 12100
  373. 12050 FOR I=1 TO LEN (D$) STEP 2
  374. 12060     X=VAL("&H"+MID$(D$,I,2)):CKSUM%=(CKSUM%+X) AND X255%
  375. 12070      GOSUB 13000:E=E+1:'write byte at offset E
  376. 12080 NEXT I
  377. 12085 CALL MOVETO(190,158):PRINT USING "####.##_K";(E/1024)
  378. 12090 GOTO 12030
  379. 12100 INPUT #1,D$:'get the checksum
  380. 12990 CLOSE:RETURN
  381. 13000 'Write Byte X at offset E
  382. 13010 POKE VARPTR(DBUF%(0)),X
  383. 13015 P(39)=INT(E/65536!):Y=E:GOSUB 20000:' offset msw
  384. 13020 P(40)=X:'offset lsw
  385. 13030 X=VARPTR (P(0)):CALL X:' write it!
  386. 13040 RC=P(16):'return code
  387. 13050 IF RC<>0 THEN CLS: PRINT "Write RF Error":GOSUB 14000:CLOSE:END
  388. 13060 RETURN
  389. 14000 'Close RF 
  390. 14010 GOSUB 10500:'Closing Header to RF routine
  391. 14020 IF RC=0 THEN RETURN
  392. 14030 PRINT "File Error on Closing RF"
  393. 14040 GOTO 14100
  394. 14050 'Open RF for E$
  395. 14060 RW=1:'set to read
  396. 14070 GOSUB 10000:'Open RF
  397. 14080 IF RC=0 THEN RETURN
  398. 14090 CLS:PRINT "FILE ERROR ON OPENING RF"
  399. 14100 PRINT "Return Code = ";RC
  400. 14110 CLOSE :END
  401. 15000 'Load Code Array
  402. 15010 I=0
  403. 15020 RESTORE 15500
  404. 15030 READ X:IF X<>-5 THEN P(I)=X:I=I+1:GOTO 15030
  405. 15040 RETURN
  406. 15500 DATA &H41FA,&H001E,&H2278,&H011C
  407. 15510 DATA &H2269,&H0010,&H2251,&H4280,&HA40A
  408. 15520 DATA &H41FA,&H000A,&H3080,&H4E75,&H7268,&H6E00,0
  409. 15530 DATA &H0000,&H0000,&H0005,&H0000
  410. 15540 DATA &H0000,&H0000,&H0000,&H0000
  411. 15550 DATA &H0001,&H0000,&H0000,&H0000
  412. 15560 DATA &HFFFE,&H0000,&H0000,&H0000
  413. 15570 DATA &H0001,&H3000,&H0000,&H0200
  414. 15580 DATA &H0000,&H0000,&H0001,&H0000,&H0000
  415. 15590 DATA-5
  416. 16000 'REad RF at E
  417. 16010 IF P(0)<>&H41FA THEN GOSUB 15000
  418. 16020 P(8)=&HA202:'Read byte
  419. 16030 P(39)=INT(E/65536!):Y=E:GOSUB 20000:'offset msw
  420. 16040 P(40)=X: 'offset lsw
  421. 16050 TR=VARPTR(DBUF%(0))
  422. 16060 P(32)=INT(TR/65536!):Y=TR:GOSUB 20000:'buffer msw
  423. 16070 P(33)=X:'buffer lsw
  424. 16080 P(34)=0:'count high
  425. 16090 P(35)=RN:'count low
  426. 16100 P(38)=1:'mode is absolute offset
  427. 16110 X=VARPTR(P(0)):CALL X:'read it!
  428. 16120 RC= P(16):'return code
  429. 16130 RX=P(37):'returned count
  430. 16140 IF RC<>0 THEN CLS:PRINT "Read RF Error":GOSUB 14000:CLOSE:END
  431. 16150 RETURN
  432. 18000 'Dump the RF
  433. 18010 E=0:CKSUM%=0:S=0
  434. 18020 IF E>=LFR-1 THEN RN=0: GOTO 18140: ELSE RN=256:IF LFR-E<=256 THEN RN=LFR-E
  435. 18030 GOSUB 16000:'get the buffer filled with RF
  436. 18040 FOR I=0 TO RX-1
  437. 18050      X9=(PEEK(VARPTR(DBUF%(0))+I))
  438. 18060      HX$=HEX$(X9):IF LEN(HX$)<2 THEN HX$="0"+HX$
  439. 18070      CKSUM%=(CKSUM%+X9) AND X255% 
  440. 18080      PRINT HX$;: PRINT #2,HX$;
  441. 18090      S=S+1:IF S>31 THEN S=0:PRINT USING " ######_/";(E+I+1);:PRINT LFR:PRINT #2,""
  442. 18120 NEXT I
  443. 18140 IF S>0 THEN PRINT #2,""
  444. 18150 IF RN<256 THEN RETURN
  445. 18160 E=E+256:GOTO 18020
  446. 18170 END
  447. 20000 X=Y-65536!*INT(Y/65536!):IF X>=32768! THEN X=X-65536!
  448. 20010 RETURN
  449. 21000 'Resource hex->bin Subroutine
  450. 21010 CLOSE #2:E$=BF$:RW=2:GOSUB 14070:'Open RF to write
  451. 21020 GOSUB 11000:'Setup To Write to RF
  452. 21030 GOSUB 12000:'Dump the Hex->RF
  453. 21040 GOSUB 14000:'Close rf
  454. 21050 RETURN
  455. 22000 'Resource Bin-> hex subroutine
  456. 22010 PRINT #2,"#";TYPEAPPL$:PRINT #2,"***RESOURCE FORK"
  457. 22020 E$=BF$:RW=1
  458. 22030 GOSUB 14070:'Open RF
  459. 22040 GOSUB 18000:'Dump Fork
  460. 22050 GOSUB 14000:'Close Fork
  461. 22060 RETURN
  462.