8-Bit Software Online Conversion
Run Archiver Program v3.0 - Listing
10REM"
xm0
20REM"
¶j5
30REM"
"'
40REM
50REM" By Andrew Black
60REM" (c) Andrew Soft 1991
70REM
80REM" This program has been rel
eased
90REM" into Public Domain
100REM"
110ON ERROR PROCerror(0)
120:
130max%=30
140*DISC
150:
160DIM osfile &20, filename &10
170DIM file$(max%), length%(max%)
180DIM saddress%(max%), eaddress%(max%
)
190DIM mark%(max%), note$(max%)
200:
210MODE 7
220VDU15
230VDU23;8202;0;0;0;
240:
250PROCtitle
260PROCmenu
270:
280END
290:
300DEF PROCdrive
310CLS
320INPUT" Which drive (0-3)"drv%
330IF drv%<0 OR drv%>3 THEN PROCdrive
340:
350PROCoscli("DR."+STR$drv%)
360:
370PRINT
380PROCoscli(".")
390:
400PRINT'" Correct drive?":G$=GET$
410IF G$="N" THEN PROCdrive
420PROCmenu
430ENDPROC
440:
450DEF PROCcompress
460PROCunmark
470version$="3.0"
480CLS
490PRINT" Compressing Mode "
500PRINT'
510:
520INPUT" How many files to compress:"
fnum%
530IF fnum%>max% OR fnum%<1 THEN PROCc
ompress
540:
550INPUT" Destination file:"dfile$
560PRINT
570INPUT" Archived by : "archive$
580INPUT" Date of archive: "date$
590PRINT
600:
610INPUT" How many note lines: "nlines
%
620IF nlines%>10 OR nlines%<1 THEN GOT
O 610
630:
640PRINT
650FOR F%=1 TO nlines%
660INPUT" Notes: "note$(F%)
670NEXT
680:
690PRINT
700:
710CLS
720FOR G%=1 TO fnum%
730PRINT" Enter file ";G%;" to compres
s"
740INPUT" : "file$(G%)
750NEXT
760:
770PROCcheck`files
780:
790output%=OPENOUT(dfile$)
800time%=((((total%+&515)/1024)*9)*1.5
)DIV1
810:
820CLS
830PRINT'" Writing file information...
"
840:
850PRINT# output%,0,0,0,version$,fnum%
,total%,archive$,date$,nlines%
860:
870FOR Q%=1 TO nlines%
880PRINT# output%,note$(Q%)
890NEXT
900:
910FOR Z%=1 TO fnum%
920PRINT# output%,file$(Z%),saddress%(
Z%),eaddress%(Z%),length%(Z%),0
930NEXT
940:
950PRINT'" Compressing files"
960PRINT" Compression time: ";(time%/3
DIV60)" min(s) ";(time% MOD60)" sec(s)"
970:
980PRINT
990FOR W%=1 TO fnum%
1000:
1010PRINT# output%,W%:REM Keeps track o
f file number
1020:
1030input%=OPENIN(file$(W%))
1040:
1050PRINT" Compressing "file$(W%)
1060PRINT
1070:
1080FOR R%=1 TO length%(W%)
1090BPUT# output%,BGET# input%
1100NEXT
1110:
1120CLOSE#input%
1130NEXT
1140:
1150CLOSE#output%
1160:
1170PRINT'" Transfer successful"
1180G$=INKEY$(200)
1190ENDPROC
1200:
1210DEFPROCwrite`block
1220$filename=file$(L%)
1230!osfile=filename
1240!(osfile+2)=saddress%(L%)
1250!(osfile+6)=eaddress%(L%)
1260X%=osfileMOD256
1270Y%=osfileDIV256
1280A%=2
1290CALL&FFDD
1300X%=osfileMOD256
1310Y%=osfileDIV256
1320A%=3
1330CALL&FFDD
1340ENDPROC
1350:
1360DEFPROCread`block
1370$filename=file$(G%)
1380!osfile=filename
1390X%=osfileMOD256
1400Y%=osfileDIV256
1410A%=5
1420CALL&FFDD
1430saddress%(G%)=!(osfile+2)
1440eaddress%(G%)=!(osfile+6)
1450ENDPROC
1460:
1470DEF PROCoscli(s$)
1480$&900=s$:X%=&00:Y%=&09:CALL&FFF7:EN
DPROC
1490:
1500DEF PROCerror(num%)
1510CLOSE#0
1520:
1530IF ERR=6 PRINT'" Not Archive file":
I$=INKEY$(200):PROCmenu:ENDPROC
1540IF ERR=17 THEN PROCmenu
1550IF num%=1 THEN PRINT'" File not fou
nd":I$=INKEY$(200):PROCmenu:ENDPROC
1560IF ERR=204 THEN PROCmenu
1570:
1580PRINT:REPORT:PRINT:END
1590ENDPROC
1600:
1610DEF PROCcheck`files
1620fils%=FNfiles
1630total%=0
1640IF fils%>max% THEN CLS:PRINT'" Aban
doning Mode":PRINT'" Catalouge full":I$=
INKEY$(400):PROCmenu:ENDPROC
1650:
1660PRINT
1670FOR G%=1 TO fnum%
1680:
1690input%=OPENIN(file$(G%))
1700IF input%=0 THEN PROCmark(G%):GOTO
1790
1710:
1720length%(G%)=EXT# input%
1730total%=length%(G%)+total%
1740:
1750:
1760CLOSE#input%
1770PROCread`block
1780:
1790NEXT
1800:
1810PROCcheck2
1820PROCcheck3
1830ENDPROC
1840:
1850DEF PROCmark(rec%)
1860mark%(rec%)=1
1870ENDPROC
1880:
1890DEF PROCcheck2
1900set=0
1910:
1920FOR K%=1 TO fnum%
1930IF mark%(K%)=1 THEN PRINT" Unable t
o find file ";file$(K%):set=1
1940NEXT
1950:
1960IF set=1 THEN I$=INKEY$(300):CLS:PR
INT" Abandoning mode":PRINT'" Unable to
find file(s)":I$=INKEY$(400):PROCmenu:EN
DPROC
1970ENDPROC
1980:
1990:
2000DEF PROCcheck3
2010ON ERROR GOTO 2080
2020:
2030PROCoscli("SAVE "+dfile$+" 0000 "+S
TR$÷(total%+&512+(&22*fnum%)))
2040:
2050ON ERROR PROCerror(0)
2060ENDPROC
2070:
2080IF ERR=198 CLS:PRINT" Abandoning mo
de":PRINT'" Not enough disk space":I$=IN
KEY$(400):PROCmenu:ENDPROC
2090:
2100PROCerror(0)
2110ENDPROC
2120:
2130DEF PROCexit
2140CLS
2150PRINT" Exit (Y/N)":G$=GET$
2160IF G$="Y" THEN END
2170PROCmenu
2180ENDPROC
2190:
2200:
2210DEF PROCexamine
2220CLS
2230PRINT" Examine Archive "
2240PRINT
2250INPUT" Enter file to examine: "bfil
e$
2260PRINT
2270INPUT" Send data to printer",G$
2280IF G$="Y" THEN set3=1 ELSE set3=0
2290:
2300input%=OPENIN(bfile$)
2310PROCex`dec(0)
2320I$=INKEY$(200)
2330ENDPROC
2340:
2350:
2360DEF PROCex`dec(choice%)
2370:
2380IF input%=0 THEN CLS:PRINT" Abandon
ing mode":PRINT'" Unable to find file ";
bfile$:I$=INKEY$(300):PROCmenu:ENDPROC
2390:
2400INPUT# input%,spare%,spare%,spare%,
version$,fnum%,total%,archive$,date$,nli
nes%
2410:
2420FOR E%=1 TO nlines%
2430INPUT# input%,note$(E%)
2440NEXT
2450:
2460:
2470FOR H%=1 TO fnum%
2480INPUT# input%,file$(H%),saddress%(H
%),eaddress%(H%),length%(H%),spare%
2490NEXT
2500:
2510IF choice%=0 THEN CLOSE#input%
2520CLS
2530IF set3=0 THEN PRINT" Archive file:
";bfile$
2540IF set3=1 THEN PRINT" Archive file:
";bfile$:VDU2
2550:
2560PRINT'" Archived with version: ";ve
rsion$
2570PRINT
2580PRINT" Archived files: ";fnum%
2590PRINT" Files total size: ";total% D
IV 1024".";(total% MOD 1024)DIV 10"K"
2600PRINT" Archived by: ";archive$
2610PRINT" Archive date: ";date$
2620PRINT
2630PRINT
2640:
2650FOR O%=1 TO nlines%
2660PRINT" Notes: ";note$(O%)
2670NEXT
2680PRINT
2690:
2700FOR U%=1 TO fnum%
2710neat$=STRING$(9-LEN(file$(U%))," ")
2720PRINT" Filename ";U%;": ";file$(U%)
;neat$" length: ";length%(U%) DIV 1024;"
.";(length%(U%) MOD 1024)DIV 10;"K"
2730IF set3=0 THEN I$=INKEY$(60)
2740NEXT
2750IF set3=1 THEN VDU3
2760:
2770PROCspace
2780ENDPROC
2790:
2800DEF PROCdecompress(switch%)
2810CLS
2820PRINT" Decompressing Mode "
2830PRINT
2840INPUT" Enter file to decompress: "b
file$
2850:
2860input%=OPENIN(bfile$)
2870:
2880set3=0
2890PROCex`dec(1)
2900IF switch%=1 THEN PROClocate:ENDPRO
C
2910PROCd`check(switch%)
2920:
2930IF set2=1 THEN PROCre`cal
2940:
2950time%=(((total%/1024)*9)*1.5)DIV1
2960:
2970CLS
2980PRINT'" Decompressing time: ";(time
%/3 DIV60)" min(s) ";(time% MOD60)" sec(
s)"
2990:
3000PROCdec`sec2
3010:
3020PRINT'" Transfer successful"
3030G$=INKEY$(200)
3040ENDPROC
3050:
3060DEFPROCtitle
3070REM You may alter this section
3080REM as you want.
3090PRINT"
ppppppppppp";
3100VDU134,157,141
3110PRINT" ARCer Vers 3.0 by Andrew Bla
ck"
3120VDU134,157,141
3130PRINT" ARCer Vers 3.0 by Andrew Bla
ck"
3140PRINT"
£££££££££££"
3150VDU28,0,24,39,4
3160ENDPROC
3170:
3180DEF PROCd`check(switch2%)
3190set2=0
3200fils%=FNfiles
3210:
3220IF switch2%=1 THEN fnum%=nofile%
3230IF fnum%>max% GOTO 3270
3240IF fnum%>(max%+1)-fils% THEN PRINT'
" Unable to decompress all files.":PRINT
'" Lack of catalouge file space":set2=1:
PRINT':INPUT" Carry on with decompressin
g",G$:IF G$="Y" THEN 3280
3250:
3260IF set2=0 ENDPROC
3270CLS:PRINT" Abandoning Mode":PRINT'"
Lack of catalouge file space":I$=INKEY$
(200):CLOSE#0:PROCmenu
3280:
3290IF set2=1 THEN fnum%=(max%+1)-fils%
3300ENDPROC
3310:
3320DEF PROCre`cal
3330total%=0
3340FOR G%=1 TO fnum%
3350total%=length%(G%)+total%
3360NEXT
3370ENDPROC
3380:
3390DEF PROCmenu
3400CLS
3410drv%=FNd
3420PRINT
3430PRINT" 1. Decompress archive"
3440PRINT'" 2. Compress archive"
3450PRINT'" 3. Examine archive"
3460PRINT'" 4. Change drive (Current: "
;drv%")"
3470PRINT'" 5. Exit"
3480PRINT'" * Operating system command"
3490G$=GET$
3500:
3510IF G$="1" THEN PROCdecompress(0)
3520IF G$="2" THEN PROCcompress
3530IF G$="3" THEN PROCexamine
3540IF G$="4" THEN PROCdrive
3550IF G$="5" THEN PROCexit
3560IF G$="*" THEN PROCstar
3570:
3580IF G$="" THEN PROCmenu ELSE PROCmen
u
3590ENDPROC
3600:
3610:
3620DEF PROCdec`sec
3630output%=OPENOUT(filec$)
3640:
3650PRINT'" Decompressing "filec$
3660:
3670FOR N%=1 TO lengthc%
3680BPUT# output%,BGET# input%
3690NEXT
3700:
3710CLOSE#output%
3720PROCwrite`block
3730ENDPROC
3740:
3750DEF PROCdec`sec2
3760FOR L%=1 TO fnum%
3770INPUT# input%,spare%:REM Number of
file
3780filec$=file$(L%)
3790lengthc%=length%(L%)
3800PROCdec`sec
3810:
3820NEXT
3830:
3840CLOSE#input%
3850ENDPROC
3860:
3870DEF PROCstar
3880CLS
3890INPUT" *"star$
3900PROCoscli(star$)
3910PROCspace
3920ENDPROC
3930:
3940DEF PROCunmark
3950FOR R%=1 TO max%
3960mark%(R%)=0
3970NEXT
3980ENDPROC
3990:
4000REM" The machine code routines
4010REM" have been substuted for the
4020REM" following FuNctions in
4030REM" semi-BASIC.
4040:
4050DEFFNfiles
4060LOCAL A%,X%,Y%,blk%
4070DIM blk% 255
4080IF FNls(0,1,1,blk%) THEN =&FF
4090=blk%?5 DIV 8
4100:
4110DEFFNd
4120LOCAL A%,X%,Y%,b%
4130DIM b% 12,drv% 20
4140b%?0=0:b%!1=drv%:b%!5=0:b%!9=0
4150A%=5:X%=b%MOD256:Y%=b%DIV256:CALL&F
FD1
4160=?(drv%+2+?drv%)
4170:
4180DEFFNls(trk%,sec%,unit%,addr%)
4190LOCAL A%,X%,Y%,blk%
4200DIM blk% 10
4210blk%?0=drv%:blk%!1=addr%:blk%?5=3:b
lk%?6=&53:blk%?7=trk%:blk%?8=sec%:blk%?9
=&20+unit%
4220A%=&7F:X%=blk%MOD256:Y%=blk%DIV256:
CALL&FFF1
4230=blk%?10
4240:
4250DEF PROCspace
4260PRINT'" Press space to conti
nue"
4270REPEATUNTILGET=32
4280ENDPROC