jshaver@APG-5.ARPA (John Science Fiction & Resume Service Shaver) (04/30/87)
----- Forwarded message # 1:
Date: Thu, 30 Apr 87 10:46:20 EDT
From: John "Science Fiction & Resume Service" Shaver <jshaver@apg-5>
To: jshaver@APG-5
Subject: Pascal DOS Conversion
The programs which follow are based upon an article in the 1982 April Byte.
The first program is a Pascal program which will read DOS directories and
extract text files, set the high bit properly and create a Pascal Text file.
-----------------------------------------------
----------------------------------------------------------------
Begin Poke chart for RWTS.OBJ0
------------------------------------------------------------------
(*get
dos*)
{ $L #11:getdos.list }
{ $s++}
program getdos;
const max = 18432;{ 36 blocks of 512 bytes max }
page = 256;{ dos sector length }
cleareol= 29; clearscreen = 12;
type byte = 0..255;
units = 1..12;
untyped_file=file;
sector=record
block:0..7;
half:(first,second)
end;
var map: packed array[0..15] of sector;
buf: packed array[0..511] of byte;
text: packed array[0..max] of byte;
sourcefile, destfile: string;
sourceunit, destunit: units;
drives : set of units;
block, trak, sec, blockcount, i: integer;
ptr : integer; { pointer to text array }
done, found : boolean; ch : char;
f : file of char;
diskfile : untyped_file; { for use with blockwrite }
procedure initialize;
begin
map[0].block := 0; map[0].half := first;
map[1].block := 7; map[1].half := first;
map[2].block := 6; map[2].half := second;
map[3].block := 6; map[3].half := first;
map[4].block := 5; map[4].half := second;
map[5].block := 5; map[5].half := first;
map[6].block := 4; map[6].half := second;
map[7].block := 4; map[7].half := first;
map[8].block := 3; map[8].half := second;
map[9].block := 3; map[9].half := first;
map[10].block:= 2; map[10].half:= second;
map[11].block:= 2; map[11].half:= first;
map[12].block:= 1; map[12].half:= second;
map[13].block:= 1; map[13].half:= first;
map[14].block:= 0; map[14].half:= second;
map[15].block:= 7; map[15].half:= second;
end;{ initialize }
PROCEDURE PRINTAT(y: integer; s: string);
begin gotoxy(0,y); write(chr(cleareol),s) end;
PROCEDURE GETNAMES;
var ok : boolean; dest : string;
begin
drives := [4,5];
repeat
write(chr(clearscreen));
printat(2,'*** GETDOS ***');
printat(5,'Units: 1. Console: 4. drive #4:');
printat(6,' 5. Drive #5: 6. Printer:');
printat(8,'Source Unit (4-5)? '); readln(sourceunit);
printat(10,'Destination unit (1-6)? ');readln(destunit);
printat(12,'Source file name: ');readln(sourcefile);
destfile := sourcefile; str(destunit,dest);
if pos('.',sourcefile ) = 0 then destfile := concat(sourcefile,'.text');
case destunit of
1: destfile := 'console:';
2: destfile := 'systerm:';
3: destfile := 'not available';
4,5:destfile := concat('#',dest,':',destfile);
6: destfile := 'printer:';
7,8,9,10,11,12: destfile := 'not implemented';
end; { case of destunit }
printat(14,concat('Destination file: ',destfile));
printat(16,'<cr> accepts, <e> exits, <sp> restarts ');
read(keyboard, ch); ok := eoln(keyboard);
if ch in ['e','E',chr(27)] then exit(program);
until ok;
end; { getnames }
PROCEDURE READSEC;
begin
block := (trak*8) +map[sec].block;
unitread(sourceunit,buf,512,block);
case map[sec].half of
first : moveleft(buf[0],text[ptr],page);
second: moveleft(buf[page],text[ptr],page);
end; { cases of map }
ptr := ptr+page;
end; {readsec}
procedure readsource;
const bytes_per_entry=35; header=11;
blanks=' ';
var name: string[30]; filetype: byte;
limit, sectorcount, entry: integer;
list: packed array[1..80,0..1] of byte;
begin
printat(18,'Reading catalog...');
trak := 17 ; ptr:=0;
for sec := 15 downto 1 do readsec;
limit := ptr-1;
ptr := header;
entry := 0;
sourcefile :=concat(sourcefile,' ') ;
repeat
name := copy(blanks,1,length(sourcefile));
entry := entry + 1;
for i := 1 to length(sourcefile) do
name[i] := chr(text[ptr+i+2]-128);
found := name = sourcefile;
if not found then
begin if (entry mod 7) = 0 then ptr := ptr + header;
ptr := ptr + bytes_per_entry
end;
until (found or (ptr> limit));
if not found then
begin printat(18,'File not found...'); exit(readsource) end;
trak := text[ptr];
sec := text[ptr+1];
filetype := text[ptr+2];
sectorcount := text[ptr+33] -1 ;
if ((filetype <>0) and (filetype <>128)) or (sectorcount>72 )then
begin founD := false; printat(18,'Not a TEXT file...');
exit(readsource) end;
ptr := 0;
readsec;
ptr := 12;
for i := 1 to sectorcount do
begin list[i,0] := text[ptr];
ptr := ptr + 1;
list[i,1] := text[ptr];
ptr := ptr + 1;
end;
if odd(sectorcount) then blockcount := (sectorcount + 1) div 2
else blockcount := sectorcount div 2;
fillchar(text[0],blockcount*512,chr(0));
printat(18,'Reading file...');
ptr := 0;
for i := 1 to sectorcount do
begin trak := list[i,0];
sec := list[i,1];
readsec
end;
end; { readsource }
PROCEDURE WRITEDEST;
var nextbyte : byte;
begin
ptr := 0;
printat(18,concat('Put ',destfile,' on line; press <cr> '));
read(keyboard,ch);
if destunit in drives then
begin
printat(18,'One moment please...');
fillchar(buf[0],512,chr(0));
for i := 0 to blockcount*512 do
if text[i]>127 then text[i] := text[i] - 128;
printat(18,concat('Writing to ',destfile,'...'));
rewrite(diskfile,destfile);
i := blockwrite(diskfile,buf,1,0);
i := blockwrite(diskfile,buf,1,1);
i := blockwrite(diskfile,text[0],blockcount,2);
close(diskfile,lock);
end
else
begin
printat(18,concat('Writing to ',destfile,'...'));
rewrite(f,destfile);
writeln(f);
repeat
nextbyte := text[ptr+1];
ch := chr(text[ptr]-128);
write(f,ch);
ptr := ptr + 1
until nextbyte = 0;
close(f,lock);
end; { else }
end; { writedest }
begin { MAIN PROGRAM }
initialize;
repeat
getnames;
readsource;
if found then writedest;
writeln;
writeln;
write('Another file? (y/nn) ');
read(keyboard,ch);
done := ch in ['N','n'];
until done
end { MAIN }.
------------------------------------------------------------
The next two programs are required in DOS to read a Pascal directory and to
convert the text file found in to a normal Apple text file. The first program is
in BASIC. Attached to it is a listing of the locations and pokes required to
create a file called RWTS.OBJ0. This is the program which actually reads
the Pascal directory and disk. These programs seem to work for both
PASCAL 1.1 and 1.2 from Apple.
-----------------------------------------------
2 GOTO 200
100 REM WRITJEJ FILE (SKIP NULLS)
105 CH = PEEK (I)
110 IF CH = 16 THEN I = I + 1:CH = 0: IF PEEK (I) > 32 THEN FOR J = 33 TO PEEK (I): PRINT " ";: NEXT J:I = I + 1: GOTO 105
115 IF CH = 0 AND I > EN THEN RETURN
120 IF CH = 0 THEN I = I + 1: GOTO 105
125 I = I + 1: PRINT CHR$ (CH);: GOTO 105
130 REM READ A BLOCK
135 SL% = SS:DR% = SD
140 TR% = INT (BLOCK / 8)
145 PT% = INT ((BLOCK / 8 - TR%) * 8)
150 SE% = M%(PT%,0): CALL RWTS
155 GOSUB 190:BU% = BU% + PAGE
160 SE% = M%(PT%,1): CALL RWTS
165 GOSUB 190:BU% = BU% + PAGE
170 RETURN
175 REM CENTER TITLE
180 HTAB 20 - LEN (T$) / 2: PRINT T$: RETURN
185 REM ERR TRAP
190 IF ER% < > 0 THEN VTAB 20: CALL - 868: PRINT "DOS ERROR...": POP : POP : GOTO 290
195 RETURN
200 REM INITIALIZE
205 RWTS = 16384: HIMEM: RWTS
210 PRINT CHR$ (4);"BLOADRWTS.OBJ0"
215 PAGE = 256
220 BU% = RWTS + PAGE:CM% = 1
225 BEG = BU%:EN = BU% + PAGE
230 M%(0,0) = 0:M%(0,1) = 14
235 M%(1,0) = 13:M%(1,1) = 12
240 M%(2,0) = 11:M%(2,1) = 10
245 M%(3,0) = 9:M%(3,1) = 8
250 M%(4,0) = 7:M%(4,1) = 6
255 M%(5,0) = 5:M%(5,1) = 4
260 M%(6,0) = 3:M%(6,1) = 2
265 M%(7,0) = 1:M%(7,1) = 15
270 REM GET FILE NAMES
275 HOME : VTAB 3
280 T$ = "*** CONVERT: PASCAL TO TEXT ***": GOSUB 180: PRINT
285 REM
290 VTAB 8: HTAB 1
295 PRINT "SOURCE SLOT : 6";
300 HTAB PEEK (36): GET IN$
305 SS = VAL (IN$)
310 IF SS = 0 THEN SS = 6
315 IF SS < 0 OR SS > 7 THEN 290
320 PRINT SS
325 VTAB 10: HTAB 1
330 PRINT "SOURCE DRIVE: 1";
335 HTAB PEEK (36): GET IN$
340 SD = VAL (IN$)
345 IF SD = 0 THEN SD = 1
350 IF SD < 1 OR SD > 2 THEN 325
355 PRINT SD
360 VTAB 12: HTAB 1
365 PRINT "DESTINATION SLOT: 6";
370 HTAB PEEK (36): GET IN$
375 DS = VAL (IN$)
380 IF DS = 0 THEN DS = 6
385 IF DS < 1 OR DS > 7 THEN 360
390 PRINT DS
395 VTAB 14: HTAB 1
400 PRINT "DESTINATION DRIVE: 2";
405 HTAB PEEK (36): GET IN$
410 DD = VAL (IN$)
415 IF DD = 0 THEN DD = 2
420 IF DD < 1 OR DD > 2 THEN 395
425 PRINT DD
430 VTAB 16: HTAB 1
435 INPUT "SOURCE FILE: ";SF$: IF LEN (SF$) = 0 THEN 430
440 VTAB 18: HTAB 1
445 INPUT "DESTINATION FILE: ";DF$
450 IF LEN (DF$) = 0 THEN DF$ = SF$: VTAB 18: PRINT "DESTINATION FILE: ";DF$
455 L2 = LEN (SF$)
460 VTAB 20: CALL - 868: PRINT "PRESS <RET> TO PROCEED; <ESC> TO END ";: GET IN$: IF IN$ = CHR$ (27) THEN 605
465 PRINT : IF IN$ < > CHR$ (13) THEN 290
470 IF SD = DD THEN VTAB 20: PRINT "INSERT THE SOURCE DISK; PRESS <RET> ";: INPUT "";IN$
475 REM GET DIRECTORY
480 VTAB 20: CALL - 868: PRINT "READING DIRECTORY..."
485 BU% = RWTS + PAGE: FOR BLOCK = 2 TO 5: GOSUB 135: NEXT BLOCK
490 EN = BU%
495 REM FIND FILE NAME
500 FOR I = BEG TO EN STEP 26:NA$ = ""
505 SB = PEEK (I) + 256 * PEEK (I + 1):NB = PEEK (I + 2) + 256 * PEEK (I + 3):L1 = PEEK (I + 6)
510 IF L1 < > L2 THEN 525
515 FOR J = I + 7 TO I + L1 + 6:NA$ = NA$ + CHR$ ( PEEK (J)): NEXT J
520 IF NA$ = SF$ THEN 540
525 NEXT I
530 IF NA$ = "" THEN VTAB 20: CALL - 868: PRINT "FILE NOT FOUND: PRESS <RET> ";: INPUT "";IN$: GOTO 290
535 REM READ SOURCE
540 VTAB 20: CALL - 868: PRINT "READING FILE..."
545 SB = SB + 2:EB = NB - 1:BU% = RWTS + PAGE
550 FOR BLOCK = SB TO EB: GOSUB 135: NEXT BLOCK
555 IF SD = DD THEN VTAB 20: CALL - 868: PRINT "INSERT DESTINATION DISK; PRESS <RET> ";: INPUT "";IN$
560 REM WRITE DEST
565 VTAB 20: CALL - 868: PRINT "WRITING..."
570 PRINT CHR$ (4);"OPEN ";DF$,"D",DD
575 PRINT CHR$ (4);"DELETE ";DF$
580 PRINT CHR$ (4);"OPEN ";DF$,"D",DD
585 PRINT CHR$ (4);"WRITE ";DF$
590 I = BEG:EN = BU% - PAGE: GOSUB 105
595 PRINT CHR$ (4);"CLOSE ";DF$
600 VTAB 20: CALL - 868: PRINT "ANOTHER FILE (Y/N) ";: GET IN$: IF IN$ = "Y" THEN 270
605 PRINT : END
CLOSE
16384 32 227 3 132 72 133 73 165
16392 184 133 30 165 185 133 31 32
16400 121 64 10 10 10 10 160 1
16408 145 72 32 127 64 160 2 145
16416 72 169 0 160 3 145 72 32
16424 133 64 160 4 145 72 32 139
16432 64 160 5 145 72 32 145 64
16440 160 8 145 72 160 0 177 131
16448 160 9 145 72 32 151 64 240
16456 39 160 12 145 72 32 157 64
16464 32 227 3 32 217 3 160 13
16472 177 72 176 2 169 0 160 1
16480 145 131 177 72 160 15 145 72
16488 160 2 177 72 160 16 145 72
16496 165 30 133 184 165 31 133 185
16504 96 32 163 64 83 76 37 32
16512 163 64 68 82 37 32 163 64
16520 84 82 37 32 163 64 83 69
16528 37 32 163 64 66 85 37 32
16536 163 64 67 77 37 32 163 64
16544 69 82 37 104 133 184 104 133
16552 185 230 184 208 2 230 185 32
16560 227 223 160 1 177 131 96 0
----- End of forwarded messages