(*$S+*) (*$V-*) PROGRAM puffin; CONST maxunit =12; (* maximum number for a pascal unit *) maxdir =105; (* maximum number of entries in a DOS diskette directory *) maxlink =122; (* maximum number of entries in a track sector list *) didleng =30; (* maximum length of a DOS file name *) pidleng =23; (* maximum length of a Pascal file name *) sidleng = 5; (* maximum length of a Pascal file name suffix, e.g. ".TEXT" *) sectsize =256; (* size of a DOS sector *) blocksize=512; pagesize =1024; (* size of a pascal text page *) maxbyte =255; dirtrack =17; (* track number where a DOS directory resides *) firstdirsect=15; (* first sector of a DOS directory *) TYPE byterange =0..maxbyte; sectrange =0..sectsize; dirrange =0..maxdir; linkrange =0..maxlink; unitrange =0..maxunit; blockrange=0..blocksize; pagerange =0..pagesize; sectbuffer =PACKED ARRAY[byterange] OF byterange; blockbuffer=PACKED ARRAY[1..blocksize] OF byterange; pagebuffer =PACKED ARRAY[1..pagesize] OF byterange; link=PACKED RECORD (* used to designate track/sector combinations *) tracknum:byterange; sectnum:byterange; END; tslist=(* track sector list *) RECORD continuation:link; list:PACKED ARRAY[1..maxlink] OF link; END; did=STRING[didleng]; pid=STRING[pidleng]; sid=STRING[sidleng]; dosfilekinds= (* DOS file types *) (volinfo,unknown,dftext,dfinteger,applesoft,binary); pasfilekinds= (* some of the Pascal file types *) (textfile,fotofile,untyped); (* Pascal format for the information contained in a DOS directory entry *) dosdirentry=PACKED RECORD CASE dfkind:dosfilekinds OF volinfo: (* this is volume info *) (dunitnum:unitrange; dnumentries:dirrange); unknown, dftext, dfinteger, applesoft, binary: (file_tsl:link; (* location of file's track-sector list*) locked:BOOLEAN; (* designates whether file is locked *) name:did; sectorcount:byterange); (* number of diskette sectors allocated *) END; dosdirectory=ARRAY[dirrange] OF dosdirentry; VAR dosdir:dosdirectory; (* current working DOS directory *) unitnum:unitrange; ioerror:INTEGER; ch:CHAR; FUNCTION readtrksec(unitnum:unitrange; trksec:link;VAR sb:sectbuffer;VAR ioerror:INTEGER):BOOLEAN; (* reads sector number 'trksec.sectnum' from tracknumber 'trksec.tracknum' on disk drive nunber 'unitnum' *) VAR block:blockbuffer; blocknum,offset:INTEGER; BEGIN WITH trksec DO BEGIN (* compute half-block corresponding to desired sector *) IF (sectnum IN [0,15]) THEN blocknum:=sectnum ELSE blocknum:=15-sectnum; IF (odd(blocknum)) THEN offset:=256 ELSE offset:=0; (* now compte blocknum off set from track 0 *) blocknum:=(blocknum DIV 2)+8*tracknum; END; (* WITH trksec DO *) (*$I-*) unitread(unitnum,block,sizeof(block),blocknum); (*$I+*) ioerror:=ioresult; IF NOT (ioerror=0) THEN readtrksec:=FALSE ELSE BEGIN (* write into sector buffer *) moveleft(block[offset+1],sb,sizeof(sectbuffer)); readtrksec:=TRUE; END; (* IF...THEN...ELSE *) END; FUNCTION writetrksec(unitnum:unitrange; trksec:link;VAR sb:sectbuffer;VAR ioerror:INTEGER):BOOLEAN; VAR blocknum,offset:INTEGER; block:blockbuffer; BEGIN (* see comments for 'readtrksec' *) WITH trksec DO BEGIN (* compute half-block corresponding to desired sector *) IF (sectnum IN [0,15]) THEN blocknum:=sectnum ELSE blocknum:=15-sectnum; IF (odd(blocknum)) THEN offset:=256 ELSE offset:=0; (* now compte blocknum off set from track 0 *) blocknum:=(blocknum DIV 2)+8*tracknum; END; (* WITH trksec DO *) (*$I-*) unitread(unitnum,block,sizeof(block),blocknum); (*$I+*) ioerror:=ioresult; IF NOT (ioerror=0) THEN writetrksec:=FALSE ELSE BEGIN moveleft(sb,block[offset+1],sizeof(sectbuffer)); (*$I-*) unitwrite(unitnum,block,sizeof(block)); (*$I+*) ioerror:=ioresult; writetrksec:=ioerror=0; END; END; FUNCTION searchdir(target:did;VAR index:dirrange):BOOLEAN; VAR found:BOOLEAN; BEGIN found:=FALSE; index:=dosdir[0].dnumentries; WHILE NOT (found OR (index=0)) DO BEGIN found:=target=dosdir[index].name; index:=index-1; END; IF found THEN index:=index+1; searchdir:=found; END; FUNCTION stoi:INTEGER; VAR ch:CHAR; x:INTEGER; BEGIN x:=0; read(ch); WHILE ch IN ['0'..'9'] DO BEGIN x:=10*x+(ord(ch)-ord('0')); read(ch); END; writeln; stoi:=x; END; FUNCTION get_unit_num(VAR unitnum:unitrange):BOOLEAN; VAR un:INTEGER; BEGIN REPEAT writeln; writeln('Enter the unitnum number [4,5,9..12] of the disk drive containing'); writeln('the DOS diskette to be cataloged. Enter 0 to escape.'); writeln; write('>> '); un:=stoi; IF NOT (un IN [0,4,5,9..12]) THEN writeln(chr(7)); UNTIL un IN [0,4,5,9..12]; unitnum:=un; get_unit_num:=(un<>0); END; PROCEDURE capitalize(VAR line:STRING); CONST ordsmla=97; ordsmlz=122; shiftcase=32; VAR index:0..maxbyte; BEGIN FOR index:=1 TO length(line) DO IF line[index] IN [chr(ordsmla)..chr(ordsmlz)] THEN line[index]:=chr(ord(line[index])-shiftcase); END; FUNCTION getpasid(VAR name:pid):BOOLEAN; BEGIN writeln; writeln('Enter the name of the Pascal destination file,'); writeln('or enter to exit:'); writeln; write('>>'); readln(name); IF (length(name)=0) THEN getpasid:=FALSE ELSE BEGIN capitalize(name); getpasid:=TRUE; END; END; FUNCTION getdosid(VAR name:did):BOOLEAN; BEGIN writeln; writeln('Enter the name of the DOS file to transfer,'); writeln('or enter to exit:'); writeln; write('>>'); readln(name); IF (length(name)=0) THEN getdosid:=FALSE ELSE BEGIN capitalize(name); getdosid:=TRUE; END; END; PROCEDURE getfiletype(VAR suffix:sid;VAR filetype:pasfilekinds); BEGIN writeln; writeln('Transfer to a:'); writeln; writeln('T)ext file, F)oto file, or D)ata (binary) file?'); writeln; write('>> '); read(keyboard,ch); WHILE NOT (ch IN ['t','f','d','T','F','D']) DO BEGIN write(chr(7));read(keyboard,ch); END; writeln(ch); CASE ch OF 'T','t':BEGIN suffix:='.TEXT';filetype:=textfile; END; 'F','f':BEGIN suffix:='.FOTO';filetype:=fotofile; END; 'D','d':BEGIN suffix:='';filetype:=untyped; END; END; END; PROCEDURE printmenu; CONST cleoln=29; BEGIN gotoxy(0,0); write(chr(cleoln),'C)atalog, D)isplay, T)ransfer, Q)uit?'); END; PROCEDURE readcommand(VAR ch:CHAR); BEGIN read(keyboard,ch); WHILE NOT(ch IN ['C','c','D','d','T','t','Q','q']) DO BEGIN write(chr(7)); read(keyboard,ch); END; writeln; END; PROCEDURE displayentry(de:dosdirentry); BEGIN WITH de DO BEGIN write(name,' ':(didleng-length(name)+1)); CASE dfkind OF dftext:write('text':6); dfinteger:write('int':6); applesoft:write('soft':6); binary:write('bnry':6); unknown:write('unkn':6); END; IF locked THEN write('yes':8) ELSE write('no':8); write(sectorcount:9); writeln(filetsl.tracknum:6,'-',filetsl.sectnum:3); END; END; PROCEDURE displayheader; BEGIN write('File Name'); write('Type':((didleng-length('file name'))+7)); write('Locked':8); write('Sectors':9); writeln('TSL link':10); END; PROCEDURE displaydir; CONST cleos=11; esc=27; maxlines=21; VAR cumsectors:INTEGER; count:dirrange; BEGIN page(output); gotoxy(0,1); cumsectors:=0; IF dosdir[0].dnumentries=0 THEN writeln('The working directory is empty!') ELSE BEGIN displayheader; FOR count:=1 TO dosdir[0].dnumentries DO BEGIN displayentry(dosdir[count]); cumsectors:=cumsectors+dosdir[count].sectorcount; IF (count MOD maxlines)=0 THEN BEGIN write('Type to continue, to stop '); read(keyboard,ch); IF ch=chr(esc) THEN exit(displaydir) ELSE BEGIN gotoxy(0,2);write(chr(cleos)); END; END; END; write(dosdir[0].dnumentries,' files on disk, ',cumsectors,' sectors in use'); END; END; PROCEDURE catalog; CONST nextlink = 1; (* relative byte 1 of directory sector is link to next directory sector *) zerobase =11; (* first byte of file info in a directory sector *) entrylength=35; (* DOS directory entries occupy 35 bytes *) mark =maxbyte; (* directory entries which have been deleted are 'marked' in (relative) byte zero *) maxindex = 7; (* maximum of 7 directory entries in a sector *) space= 32; (* ASCII space *) tilde=126; (* ASCII tilde *) TYPE indexrange=0..maxindex; entrybuffer=PACKED ARRAY[1..entrylength] OF byterange; VAR sectorindex:indexrange; entrybase:byterange; dir_link:link; dir_sector:sectbuffer; nextentry:entrybuffer; entrycount:dirrange; FUNCTION eodir(dirlink:link):BOOLEAN; BEGIN WITH dirlink DO eodir:=(sectnum=0) AND (tracknum=0); END; PROCEDURE fill_dir_entry(VAR de:dosdirentry;VAR eb:entrybuffer); CONST linkoffset = 1; (* relative byte zero for an entry gives the location of its track-sector list *) kindoffset = 3; (* relative byte 2 designates the file type of the entry *) nameoffset = 4; (* relative byte 3 is the beginning of the file name *) countoffset=34; (* relative byte 33 is the sector count (MOD sectsize) for the file *) lockbit =128; (* locked files have the high bit of the file type byte set *) VAR j,kind:byterange; nonblank:0..didleng; BEGIN WITH de DO BEGIN filetsl.tracknum:=eb[linkoffset]; filetsl.sectnum:=eb[linkoffset+1]; kind:=eb[kindoffset]; IF NOT ((kind MOD lockbit) IN [0,1,2,4]) THEN dfkind:=unknown ELSE CASE (kind MOD lockbit) OF 0:dfkind:=dftext; 1:dfkind:=dfinteger; 2:dfkind:=applesoft; 4:dfkind:=binary; END; IF ((kind DIV lockbit)=1) THEN locked:=TRUE ELSE locked:=FALSE; FOR j:=0 TO (didleng-1) DO BEGIN (* set the high bit low to get true ASCII *) eb[nameoffset+j]:=eb[nameoffset+j] MOD 128; (* eliminate any weird characters *) IF NOT (eb[nameoffset+j] IN [space..tilde]) THEN eb[nameoffset+j]:=space; END; (* find the leftmost trailing blank in the name field *) nonblank:=-scan(-didleng,<>' ',eb[nameoffset+didleng-1]); (* non_blank=0 if and only if no trailing blanks *) (* initialize the length of 'name' *) (*$R-*) name[0]:=chr(didleng-nonblank); (*$R+*) (* finally move in the name *) moveleft(eb[nameoffset],name[1],length(name)); sectorcount:=eb[countoffset]; END; (* WITH de DO *) END; (* filldirentry *) FUNCTION eodirsector(VAR index:indexrange; VAR dirsector:sectbuffer;VAR entrybase:byterange):BOOLEAN; VAR nofile:BOOLEAN; BEGIN nofile:=TRUE; WHILE (nofile AND (index pagesize) THEN primfull:=TRUE ELSE BEGIN moveleft(sparepage[lagindex+1],primpage[pagepntr+1],leadindex+1); pagepntr:=pagepntr+leadindex+1; lagindex:=lagindex+leadindex+1; endofspare:=(lagindex=sparepntr); END; END; IF primfull THEN pagepntr:=pagesize; moveleft(sparepage[lagindex+1],sparepage,sparepntr-lagindex); sparepntr:=sparepntr-lagindex; END;(* stufftext *) PROCEDURE stuffoto; CONST fotoffset=4; (* four bytes of DOS address junk in the first sector *) BEGIN IF fotoflag (* first foto sector *) THEN BEGIN moveleft(s[fotoffset],primpage,sectsize-fotoffset); pagepntr:=sectsize-fotoffset; fotoflag:=FALSE; END ELSE BEGIN moveleft(sparepage,primpage[pagepntr+1],sparepntr); pagepntr:=sparepntr+pagepntr; sparepntr:=0; IF ((pagepntr+sectsize) <= pagesize) (* i.e., enough room for a sector *) THEN BEGIN moveleft(s,primpage[pagepntr+1],sectsize); pagepntr:=pagepntr+sectsize; END ELSE BEGIN (* move as much as possible into the primary page *) moveleft(s,primpage[pagepntr+1],pagesize-pagepntr); (* move the rest into the spare page *) (* begin by updating sparepntr *) sparepntr:=sectsize-(pagesize-pagepntr); moveleft(s[pagesize-pagepntr],sparepage,sparepntr); (* update pagepntr to end of page *) pagepntr:=pagesize; END; END; END; BEGIN IF (filetype=textfile) THEN stufftext ELSE IF (filetype=fotofile) THEN stuffoto ELSE BEGIN moveleft(s,p[pagepntr+1],sectsize); pagepntr:=pagepntr+sectsize; END; END; BEGIN page(output); IF NOT (getdosid(dosname)) THEN exit(transfer); WHILE NOT (searchdir(dosname,dirindex)) DO BEGIN writeln; writeln(dosname,' not in current dosdir'); IF NOT (getdosid(dosname)) THEN exit(transfer); END; writeln; displayheader; displayentry(dosdir[dirindex]); nextnode:=dosdir[dirindex].file_tsl; getfiletype(suffix,filetype); IF NOT (getpasid(pasname)) THEN exit(transfer); WHILE NOT (openfile(concat(pasname,suffix),pasfile,ioerror)) DO BEGIN writeln; writeln('IO error ',ioerror,' opening ',concat(pasname,suffix)); IF NOT (getpasid(pasname)) THEN exit(transfer); END; (* initalize the page buffers and associated pointers *) fillchar(primpage,pagesize,chr(0)); fillchar(sparepage,pagesize,chr(0)); pagepntr:=0; sparepntr:=0; relblock:=0; IF (filetype=fotofile) THEN fotoflag:=TRUE ELSE IF (filetype=textfile) THEN (* write two header blocks of nulls *) BEGIN relblock:=blockwrite(pasfile,primpage,1,relblock)+relblock; relblock:=blockwrite(pasfile,primpage,1,relblock)+relblock; END; WHILE NOT eolist(nextnode) DO IF NOT (get_node(nextnode,currentnode)) THEN abortxfer(ioerror) ELSE BEGIN linkindex:=0; WHILE NOT eonode(linkindex,nextlink) DO IF NOT (readtrksec(dosdir[0].dunitnum,nextlink,nextsector,ioerror)) THEN abortxfer(ioerror) ELSE BEGIN stuff(nextsector,primpage,pagepntr,filetype); IF (pagepntr=pagesize) THEN BEGIN writeblocks(primpage,pagepntr,2,relblock); pagepntr:=0; fillchar(primpage,pagesize,chr(0)); END; END; nextnode:=currentnode.continuation; END; (* pick up anything in the spare page *) moveleft(sparepage,primpage[pagepntr+1],sparepntr); pagepntr:=pagepntr+sparepntr; (* if page is partially full it needs to be written *) IF (pagepntr>0) THEN (* note: pagepntr