10 ! Program CPMWrite
20 INTEGER : EXTEND : OPTION BASE 0
30 DIM Ori$=4,Dest$=4,Dummy$=1
40 True=-1 : False=0
50 !
60 Ori$="MF0:" : Dest$="MF1:"
70 !
80 ! Ver-/-Datum----/-Kommentar-----------------------------------------
90 ! 1.00 1989-12-29 <6057> Jan-Olof Svensson
92 ! 1.02 1990-02-26 <6057> Fel vid skrivning av ny katalogpost r{ttade.
93 ! . FNUpcase$ tillkommer.
98 ! 1.06 1990-09-01 <6057> FNUpcase$,FNDisplaydir$,FNClearline$,
99 ! . FNAddext$: nya versioner.
500 !
510 ; CHR$(12) "CPMWrite"
520 ;
530 Dummy$=FNInit$+FNInform$
540 ; "Kopiering fr}n ABC-format i " Ori$ " till "; : IF Wid=40 THEN ;
550 ; "CP/M 3.0 i " Dest$
560 ;
570 ; "S{tt i CP/M-skivan i " Dest$ " och tryck "; : IF Wid=40 THEN ;
580 ; ""
590 WHILE SYS(5)<>0 : GET Dummy$ : WEND
600 GET Dummy$
610 ; "Katalogen l{ses in"
620 Dummy$=FNReaddir$
630 !
640 WHILE NOT Quit
650 Dummy$=FNMenu$
660 ON Choice GOTO 670,690,710,730,750,770,790
670 Dummy$=FNCopyfile$
680 GOTO 780
690 Dummy$=FNCpmdir$
700 GOTO 780
710 Dummy$=FNShowsector$
720 GOTO 780
730 Dummy$=FNShowreserved$
740 GOTO 780
750 Dummy$=FNErasefile$
760 GOTO 780
770 Dummy$=FNRenamefile$
780 WEND
790 ; CHR$(12);
800 END
810 !
820 DEF FNWherex=PEEK(65362)
830 !
840 DEF FNWherey=PEEK(65363)
850 !
860 DEF FNOdd(X)=(MOD(X,2)=1)
870 !
880 DEF FNMax.(A.,B.)=(A.+B.+ABS(A.-B.))/2.
890 !
900 DEF FNMin.(A.,B.)=(A.+B.-ABS(A.-B.))/2.
910 !
920 DEF FNDevnumber(D$) LOCAL Devs$=93
930 Devs$='DR0DR1DR2DR3HD0HD1HD2HD3MF0MF1MF2MF3MO0MO1MO2MO3SF0SF1SF2SF3SO0SO1SO2SO3'+SPACE$(5*3)+'RAMUFD'
940 RETURN (INSTR(1,Devs$,LEFT$(D$,3))-1)/3
950 FNEND
960 !
970 DEF FNInit$
980 Dirstart=32 : Dirlen=16 : Maxsec=2559
990 DIM Reserved$=157,Newclusters$=16,Cpmbuf$=0
1000 DIM Dir$(Dirlen-1)=256,Sort$(Dirlen*8-1)=15
1010 DIM Workline$=256,Abcbuf$=253,Filename$=16,Nameindir$=11
1020 POKE VAROOT(Cpmbuf$),0,1,0,245,0,1
1030 Ori=FNDevnumber(Ori$)
1040 Dest=FNDevnumber(Dest$)
1050 IF Ori<0 OR Dest<0 OR Ori=Dest THEN ; "Felaktigt enhetsnamn!" : STOP
1060 Abc=800 : IF PEEK(39)=4 THEN Abc=806 ELSE IF PEEK(39)=3 THEN Abc=802
1070 Wid=PEEK(65364)
1080 RETURN ""
1090 FNEND
1100 !
1110 DEF FNClearline$
1120 ; CHR$(13) SPACE$(Wid) CHR$(13);
1130 RETURN ""
1140 FNEND
1150 !
1160 DEF FNUpcase$(Ch$)
1170 IF Ch$>="`" AND Ch$<="~" THEN RETURN CHR$(ASCII(Ch$) AND 223)
1180 RETURN Ch$
1190 FNEND
1200 !
1210 DEF FNCaps$(Txt$) LOCAL Newtxt$=160,Pos
1220 Newtxt$="" : Pos=1
1230 WHILE Pos<=LEN(Txt$)
1240 Newtxt$=Newtxt$+FNUpcase$(MID$(Txt$,Pos,1))
1250 Pos=Pos+1
1260 WEND
1270 RETURN Newtxt$
1280 FNEND
1290 !
1300 DEF FNInform$ LOCAL Txt$=160,Info$=16,Answer$=1,Pf1$=1,Ln,Eof,Quit
1310 ; "Vill du ha information? (J/N) N" CHR$(8);
1320 GET Answer$
1330 IF FNUpcase$(Answer$)<>"J" THEN RETURN FNClearline$
1340 ; CHR$(12) "CPMWrite"
1350 ; STRING$(Wid-1,45)
1360 ;
1370 Info$="CPMWRITE.INF"
1380 Pf1$=CHR$(192) : Ln=3 : Eof=False : Quit=False
1390 ON ERROR GOTO 1530
1400 OPEN Info$ AS FILE 1
1410 WHILE NOT (Eof OR Quit)
1420 INPUT LINE #1,Txt$
1430 ; LEFT$(Txt$,LEN(Txt$)-2)
1440 Ln=Ln+1
1450 IF Ln>=22 THEN ; "Tryck "; : GET Answer$ : Ln=0 : Dummy$=FNClearline$
1460 IF Answer$=Pf1$ THEN Quit=True
1470 WEND
1480 CLOSE
1490 ; : ; " Starta ";
1500 WHILE SYS(5)<>0 : GET Dummy$ : WEND
1510 GET Dummy$ : ; CHR$(12);
1520 RETURN ""
1530 ON INSTR(1,CHR$(21,34),CHR$(ERRCODE))+1 GOTO 1540,1550,1560
1540 ; "Fel nr" ERRCODE : RESUME 1480
1550 ; "Hittar ej filen " Info$ : RESUME 1480
1560 Eof=True : RESUME 1470
1570 FNEND
1580 !
1590 DEF FNReadsec(Drive,Sec) LOCAL D
1600 POKE SYS(10)-511,Drive
1610 D=CALL(24678,Sec)
1620 RETURN (PEEK(SYS(10)-491)<>0)
1630 FNEND
1640 !
1650 DEF FNWritesec(Drive,Sec) LOCAL D
1660 POKE SYS(10)-511,Drive
1670 D=CALL(24675,Sec)
1680 RETURN (PEEK(SYS(10)-491)<>0)
1690 FNEND
1700 !
1710 DEF FNDiscerror$ LOCAL Txt$=20,I,Code
1720 RESTORE 1790
1730 WHILE I<4
1740 READ Code,Txt$
1750 IF (PEEK(SYS(10)-491) AND Code)=Code THEN RETURN Txt$
1760 I=I+1
1770 WEND
1780 RETURN 'Ok{nd typ av diskfel!'
1790 DATA 8,'Checksummafel!'
1800 DATA 16,'D}lig disk!'
1810 DATA 64,'Skivan skrivskyddad!'
1820 DATA 128,'Luckan |ppen!'
1830 FNEND
1840 !
1850 DEF FNRes$(Char$) LOCAL Pos,Found
1860 Pos=LEN(Reserved$) : Found=False
1870 WHILE NOT (Pos=0 OR Found)
1880 IF Char$0 THEN 2200
2150 Pos=17
2160 WHILE Pos<=32
2170 IF INSTR(1,CHR$(0,229),MID$(Dir$(Index),Entry*32+Pos,1))=0 THEN Dummy$=FNRes$(MID$(Dir$(Index),Entry*32+Pos,1))
2180 Pos=Pos+1
2190 WEND
2200 Entry=Entry+1
2210 WEND
2220 RETURN ""
2230 FNEND
2240 !
2250 DEF FNReaddir$
2260 Sector=Dirstart : Index=0
2270 WHILE IndexN THEN 2400
2500 Quit=(Choice=N)
2510 RETURN ""
2520 RESUME 2380 ! Inmatningsfel
2530 DATA "Kopiera textfil"
2540 DATA "Inneh}ll, CP/M-diskett"
2550 DATA "Titta p} CP/M-sektor"
2560 DATA "Vilka filsegment {r upptagna?"
2570 DATA "Radera CP/M-fil"
2580 DATA "D|pa om CP/M-fil"
2590 DATA "Avsluta / Byta CP/M-diskett"
2600 FNEND
2610 !
2620 DEF FNAddext$(Filename$,Ext$) LOCAL Cpos
2630 IF Filename$="" THEN RETURN ""
2640 IF INSTR(1,Filename$,".")>0 THEN RETURN Filename$
2650 Cpos=INSTR(1,Filename$,":")
2660 IF Cpos>0 THEN IF Filename$="CAS:" OR INSTR(1," MEM: PR: V24: CON: NUL:"," "+LEFT$(Filename$,Cpos))>0 THEN RETURN Filename$
2670 IF ASCII(Ext$)=46 THEN RETURN Filename$+Ext$
2680 RETURN Filename$+"."+Ext$
2690 FNEND
2700 !
2710 DEF FNRespell$(Filename$) LOCAL Tmp$=12,Pos,Diacritic
2720 Pos=1 : Tmp$=Filename$
2730 WHILE Pos<=LEN(Tmp$)
2740 Diacritic=INSTR(1,"][\}{|",MID$(Tmp$,Pos,1))
2750 IF Diacritic>0 THEN MID$(Tmp$,Pos,1)=MID$("AAOaao",Diacritic,1)
2760 Pos=Pos+1
2770 WEND
2780 RETURN Tmp$
2790 FNEND
2800 !
2810 DEF FNNameok(Msg) LOCAL Newname$=12,Wait
2820 Filename$=FNCaps$(Filename$)
2830 Filename$=FNAddext$(Filename$,".TXT")
2840 IF INSTR(1,Filename$,":")>0 THEN ; "Hittar ej filen " Ori$ Filename$ : Filename$="" : RETURN False
2850 Newname$=FNRespell$(Filename$)
2860 IF Newname$=Filename$ THEN 2880
2870 IF Msg THEN ; "CP/M godtar inte ],[ och \ i filnamn." : ; "Namnet {ndras d{rf|r till " Newname$ : WHILE Wait<1500 : Wait=Wait+1 : WEND
2880 Nameindir$=LEFT$(Newname$,INSTR(1,Newname$,".")-1)
2890 Nameindir$=Nameindir$+SPACE$(8-LEN(Nameindir$))+RIGHT$(Newname$,INSTR(1,Newname$,".")+1)
2900 Nameindir$=Nameindir$+SPACE$(11-LEN(Nameindir$))
2910 RETURN True
2920 FNEND
2930 !
2940 DEF FNUsed LOCAL Found
2950 Index=0 : Found=False
2960 WHILE Index"J" THEN 3070
3110 WHILE Index0
3420 Dummy$=FNRes$(LEFT$(Newclusters$,1))
3430 Newclusters$=RIGHT$(Newclusters$,2)
3440 WEND
3450 !
3460 Cpmbuf$=Dir$(Index)
3470 Sector=Sector+Index
3480 Errflag=FNWritesec(Dest,Sector)
3490 IF Errflag THEN ; : ; FNDiscerror$ : STOP
3500 RETURN ""
3510 FNEND
3520 !
3530 DEF FNNextsector
3540 WHILE INSTR(1,Reserved$,CHR$(Cluster))>0
3550 Cluster=Cluster+1
3560 WEND
3570 IF Eof AND Workline$="" THEN 3610
3580 IF Cluster>PEEK2(VAROOT(Reserved$)) THEN ; "Filen f}r inte plats!" : STOP
3590 IF LEN(Newclusters$)=PEEK2(VAROOT(Newclusters$)) THEN Dummy$=FNWritedir$
3600 Newclusters$=Newclusters$+CHR$(Cluster)
3610 RETURN Cluster*16+32
3620 FNEND
3630 !
3640 DEF FNReadfile$
3650 ON ERROR GOTO 3680
3660 INPUT LINE #1,Abcbuf$
3670 RETURN ""
3680 IF ERRCODE=34 THEN Eof=True : Abcbuf$=CHR$(26) : RESUME 3670 ELSE ; "Fel nr" ERRCODE : STOP
3690 FNEND
3700 !
3710 DEF FNWritefile$ LOCAL Pos
3720 IF LEN(Workline$)+LEN(Abcbuf$)>256 THEN Pos=256-LEN(Workline$) : Workline$=Workline$+LEFT$(Abcbuf$,Pos) : Abcbuf$=RIGHT$(Abcbuf$,Pos+1)
3730 IF LEN(Workline$)<=128 THEN Filesize=Filesize+1 ELSE Filesize=Filesize+2
3740 IF LEN(Workline$)<128 THEN Workline$=Workline$+STRING$(128-LEN(Workline$),26) ELSE Workline$=Workline$+STRING$(256-LEN(Workline$),26)
3750 Cpmbuf$=Workline$+STRING$(256-LEN(Workline$),0)
3760 Errflag=FNWritesec(Dest,Sector)
3770 IF Errflag THEN ; : ; FNDiscerror$ : STOP
3780 Workline$=Abcbuf$ : Sector=Sector+1
3790 RETURN ""
3800 FNEND
3810 !
3820 DEF FNCopyfile$ LOCAL Old,Ready
3830 Ready=False
3840 ; CHR$(12);
3850 WHILE NOT Ready
3860 INPUT "Filnamn: "Filename$
3870 Ready=(Filename$="")
3880 IF NOT Ready THEN Dummy$=FNCheckname$(True)
3890 WHILE NOT (Filename$="")
3900 ON ERROR GOTO 4070
3910 Workline$="" : Newclusters$="" : Cluster=1 : Eof=False
3920 Sector=FNNextsector : Old=Sector
3930 Filesize=0
3940 OPEN Ori$+Filename$ AS FILE 1
3950 WHILE NOT Eof
3960 Dummy$=FNReadfile$
3970 IF LEN(Workline$)+LEN(Abcbuf$)>256 THEN Dummy$=FNWritefile$ ELSE Workline$=Workline$+Abcbuf$
3980 IF Sector=Old+16 THEN Cluster=Cluster+1 : Sector=FNNextsector : Old=Sector
3990 WEND
4000 IF LEN(Workline$)>0 THEN Dummy$=FNWritefile$
4010 IF LEN(Newclusters$)>0 THEN Dummy$=FNWritedir$
4020 CLOSE
4030 Filename$=""
4040 WEND
4050 WEND
4060 RETURN ""
4070 IF ERRCODE=21 THEN ; "Hittar ej filen " Filename$ ELSE ; "Fel nr" ERRCODE
4080 RESUME 4030
4090 FNEND
4100 !
4110 DEF FNOldsize(Code$) LOCAL Byte1,Byte2,Byte3
4120 Byte2=ASCII(Code$)
4130 Byte3=ASCII(RIGHT$(Code$,3))
4140 Byte1=ASCII(RIGHT$(Code$,4))
4150 RETURN Byte3*4096+Byte2*128+Byte1
4160 FNEND
4170 !
4180 DEF FNQuicksort(Index) LOCAL R,L,M,H,I,J,K,End,T$=15,A$=15
4190 R=Index-1 : L=0 : M=10
4200 IF (R-L)>M THEN K=0 ELSE 4840
4210 I=L+1
4220 J=(L+R)/2
4230 T$=Sort$(J)
4240 Sort$(J)=Sort$(I)
4250 Sort$(I)=T$
4260 J=R
4270 WHILE Sort$(L)>Sort$(I)
4280 T$=Sort$(L)
4290 Sort$(L)=Sort$(I)
4300 Sort$(I)=T$
4310 IF End WEND
4320 WHILE Sort$(I)>Sort$(R)
4330 T$=Sort$(R)
4340 Sort$(R)=Sort$(I)
4350 Sort$(I)=T$
4360 IF End WEND
4370 WHILE Sort$(L)>Sort$(I)
4380 T$=Sort$(L)
4390 Sort$(L)=Sort$(I)
4400 Sort$(I)=T$
4410 IF End WEND
4420 I=I+1 : IF I>(Index-1) THEN 4440
4430 IF T$>Sort$(I) THEN 4420
4440 J=J-1 : IF J<0 THEN 4460
4450 IF T$I
4470 A$=Sort$(I)
4480 Sort$(I)=Sort$(J)
4490 Sort$(J)=A$
4500 GOTO 4420
4510 IF End WEND
4520 Sort$(L+1)=Sort$(J)
4530 Sort$(J)=T$
4540 H=R-J
4550 I=J-L
4560 WHILE H>=I AND I>M
4570 K=K+1
4580 L(K)=J+1
4590 R(K)=R
4600 R=J-1
4610 GOTO 4210
4620 IF End WEND
4630 WHILE I>H AND H>M
4640 K=K+1
4650 L(K)=L
4660 R(K)=J-1
4670 L=J+1
4680 GOTO 4210
4690 IF End WEND
4700 WHILE I>M AND H<=M
4710 R=J-1
4720 GOTO 4210
4730 IF End WEND
4740 WHILE H>M AND I<=M
4750 L=J+1
4760 GOTO 4210
4770 IF End WEND
4780 WHILE K
4790 L=L(K)
4800 R=R(K)
4810 K=K-1
4820 GOTO 4210
4830 IF End WEND
4840 FOR I1=1 TO Index-1
4850 T$=Sort$(I1)
4860 FOR J1=I1-1 TO 0 STEP -1 : IF T$Wid-18 THEN ;
5100 IF FNWherey>=19 THEN ; : ; "Mera"; : GET Dummy$ : ; CHR$(12);
5110 Index=Index+1
5120 WEND
5130 ; : ;
5140 Allowed=PEEK2(VAROOT(Reserved$))
5150 ; "]terst}r" Allowed-LEN(Reserved$) "filsegment "; : IF Wid=40 THEN ;
5160 ; "(" NUM$((Allowed-LEN(Reserved$))*16) " sektorer av " NUM$(Allowed*16) ")"
5170 ;
5180 WHILE SYS(5)<>0 : GET Dummy$ : WEND
5190 ; "Menyn"; : GET Dummy$
5200 RETURN ""
5210 FNEND
5220 !
5230 DEF FNCpmdir$ LOCAL Entry,Index,N,Found,Dummy
5240 ; CHR$(12) "Katalogen sorteras i bokstavsordning. "; : IF Wid=40 THEN ;
5250 ; "Filer med flera katalogposter r{knas "; : IF Wid=40 THEN ;
5260 ; "ihop."
5270 Index=0 : N=0
5280 WHILE Index=0 AND Sector<=Maxsec AND NOT Quit
5610 ; "Sektor " Sector
5620 Errflag=FNReadsec(Dest,Sector)
5630 IF Errflag THEN ; : ; FNDiscerror$ : STOP
5640 Pos=1
5650 WHILE Pos<=LEN(Cpmbuf$)
5660 Code=ASCII(RIGHT$(Cpmbuf$,Pos))
5670 IF (Code>32 AND Code<127) THEN ; CHR$(Code); ELSE Dummy$=FNInv$("#"+NUM$(Code))
5680 IF FNWherex>Wid-5 THEN ;
5690 IF Wid=40 THEN IF Pos=128 THEN ; : ; "Tryck "; : GET Dummy$ : ;
5700 Pos=Pos+1
5710 WEND
5720 ;
5730 ; "N{sta? (J/N) J" CHR$(8); : GET Answer$
5740 IF FNUpcase$(Answer$)="N" THEN Quit=True ELSE Sector=Sector+1
5750 Dummy$=FNClearline$
5760 WEND
5770 RETURN ""
5780 RESUME 5770
5790 FNEND
5800 !
5810 DEF FNShowreserved$ LOCAL Pos
5820 Pos=1
5830 ; CHR$(12);
5840 IF Reserved$="" THEN ; "Disketten {r tom." ELSE ; "F|ljande filsegment {r upptagna: "
5850 WHILE Pos<=LEN(Reserved$)
5860 ; USING "####" ASCII(RIGHT$(Reserved$,Pos));
5870 IF FNWherex>Wid-5 THEN ;
5880 Pos=Pos+1
5890 WEND
5900 ; : ;
5910 WHILE SYS(5)<>0 : GET Dummy$ : WEND
5920 ; "Menyn"; : GET Dummy$
5930 RETURN ""
5940 FNEND
5950 !
5960 DEF FNErasefile$ LOCAL Answer$=1,Search
5970 Sector=Dirstart
5980 ; "Vilken fil skall" FLSH FNInv$("RADERAS") STDY " ? ";
5990 INPUT ""Filename$
6000 IF Filename$="" THEN RETURN ""
6010 IF NOT FNNameok(False) THEN 5970
6020 IF NOT FNUsed THEN ; "Hittar ej filen!" : GOTO 5970
6030 INPUT "Absolut s{ker? (J/N) "Answer$
6040 IF FNUpcase$(Answer$)="N" THEN Filename$="" : RETURN ""
6050 IF FNUpcase$(Answer$)<>"J" THEN 6030
6060 WHILE Index