initial commit
This commit is contained in:
slederer
commit
60db522e87
107 changed files with 36924 additions and 0 deletions
52
progs/dumpdir.pas
Normal file
52
progs/dumpdir.pas
Normal file
|
|
@ -0,0 +1,52 @@
|
|||
(* Copyright 2021-2024 Sebastian Lederer. See the file LICENSE.md for details *)
|
||||
program dumpdir;
|
||||
var volname:string;
|
||||
volid:integer;
|
||||
|
||||
(* we use some stuff internal to stdlib.pas *)
|
||||
procedure getdirslot(volumeid:integer;slotNo:integer;var result:DirectorySlot;var error:integer);
|
||||
external;
|
||||
|
||||
procedure dumpdir(volid:integer);
|
||||
var dirs:DirectorySlot;
|
||||
i:integer;
|
||||
lastSlot:integer;
|
||||
error:integer;
|
||||
begin
|
||||
lastSlot := volumeTable[volid].part.dirSize - 1;
|
||||
openvolumeid(volid);
|
||||
|
||||
for i := 0 to lastSlot do
|
||||
begin
|
||||
getdirslot(volid, i, dirs, error);
|
||||
with dirs do
|
||||
begin
|
||||
write('slot ', i, ' ', name, ' ', sizeBytes, ' G', generation);
|
||||
if SlotFirst in flags then write(' First');
|
||||
if SlotExtent in flags then write(' Extent');
|
||||
if SlotReserved in flags then write(' Resvd');
|
||||
if SlotDeleted in flags then write(' Del');
|
||||
if SlotFree in flags then write(' Free');
|
||||
if SlotEndScan in flags then write(' End');
|
||||
writeln;
|
||||
if SlotEndScan in flags then break;
|
||||
end;
|
||||
end;
|
||||
|
||||
closevolumeid(volid);
|
||||
end;
|
||||
|
||||
begin
|
||||
if ParamCount > 0 then
|
||||
volname := ParamStr(1)
|
||||
else
|
||||
begin
|
||||
write('Volume name> ');
|
||||
readln(volname);
|
||||
end;
|
||||
volid := findvolume(volname);
|
||||
if volid < 1 then
|
||||
writeln('Volume not found.')
|
||||
else
|
||||
dumpdir(volid);
|
||||
end.
|
||||
2491
progs/editor.pas
Normal file
2491
progs/editor.pas
Normal file
File diff suppressed because it is too large
Load diff
742
progs/partmgr.pas
Normal file
742
progs/partmgr.pas
Normal file
|
|
@ -0,0 +1,742 @@
|
|||
(* Copyright 2021-2024 Sebastian Lederer. See the file LICENSE.md for details *)
|
||||
program partmgr;
|
||||
const MaxPartitions = 32;
|
||||
LastPartBlock = 7;
|
||||
PartsPerBlock = 8;
|
||||
|
||||
var partTable:array[0..LastPartBlock] of PartitionTableBlock;
|
||||
changed:array[0..LastPartBlock] of boolean;
|
||||
detectedCardSize:integer;
|
||||
cmd:char;
|
||||
done:boolean;
|
||||
lastPartNo:integer;
|
||||
|
||||
function flags2str(flags:PartFlags):string;
|
||||
begin
|
||||
flags2str := '';
|
||||
|
||||
if PartEnabled in flags then flags2str := flags2str + 'E ';
|
||||
if PartBoot in flags then flags2str := flags2str + 'B ';
|
||||
if PartLast in flags then flags2str := flags2str + 'L ';
|
||||
if PartPhysical in flags then flags2str := flags2str + 'P ';
|
||||
if PartDefault in flags then flags2str := flags2str + 'D ';
|
||||
end;
|
||||
|
||||
function str2flags(var s:string):PartFlags;
|
||||
begin
|
||||
str2flags := [];
|
||||
|
||||
if 'E' in s then str2flags := str2flags + [PartEnabled];
|
||||
if 'B' in s then str2flags := str2flags + [PartBoot];
|
||||
if 'L' in s then str2flags := str2flags + [PartLast];
|
||||
if 'P' in s then str2flags := str2flags + [PartPhysical];
|
||||
if 'D' in s then str2flags := str2flags + [PartDefault];
|
||||
end;
|
||||
|
||||
function sanitizeName(var name:string):string;
|
||||
begin
|
||||
if (length(name) <= 32) and (maxlength(name) = 32) then
|
||||
sanitizeName := name
|
||||
else
|
||||
sanitizeName := '<invalid>';
|
||||
end;
|
||||
|
||||
procedure changeNumber(prompt:string; var num:integer);
|
||||
var buf:string;
|
||||
err:integer;
|
||||
digits:string;
|
||||
begin
|
||||
str(num, digits);
|
||||
buf := prompt + ' [' + digits + ']> ';
|
||||
write(buf:30);
|
||||
readln(buf);
|
||||
val(buf,num,err);
|
||||
end;
|
||||
|
||||
|
||||
procedure readPartTable;
|
||||
var done:boolean;
|
||||
curblk:integer;
|
||||
error:integer;
|
||||
devid:integer;
|
||||
begin
|
||||
done := false;
|
||||
curblk := 0;
|
||||
devid := 0; (* we only support one device *)
|
||||
|
||||
while not done do
|
||||
begin
|
||||
changed[curBlk] := false;
|
||||
|
||||
readPartBlk(curblk, partTable[curblk], error, devid);
|
||||
if error <> 0 then
|
||||
begin
|
||||
done := true;
|
||||
writeln('Error ', error,
|
||||
' reading partition block ', curblk);
|
||||
end
|
||||
else
|
||||
curblk := curblk + 1;
|
||||
|
||||
|
||||
if curBlk > LastPartBlock then
|
||||
done := true;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure writePartBlock(no:integer);
|
||||
var error:integer;
|
||||
devid:integer;
|
||||
begin
|
||||
devid := 0;
|
||||
writePartBlk(no, partTable[no], error, devid);
|
||||
if error <> 0 then
|
||||
writeln('Error ', error,
|
||||
' reading partition block ', no);
|
||||
end;
|
||||
|
||||
procedure writePartitions;
|
||||
var blkNo:integer;
|
||||
begin
|
||||
for blkNo := 0 to LastPartBlock do
|
||||
begin
|
||||
if changed[blkNo] then
|
||||
begin
|
||||
writeln('Writing back partition block ',blkNo);
|
||||
writePartBlock(blkNo);
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
|
||||
function getPartition(partNo:integer):Partition;
|
||||
var blkNo:integer;
|
||||
begin
|
||||
blkNo := partNo div PartsPerBlock;
|
||||
if (blkNo < 0) or (blkNo > LastPartBlock) then
|
||||
writeln('internal error: invalid part no in getPartition')
|
||||
else
|
||||
getPartition := partTable[blkNo][partNo mod PartsPerBlock];
|
||||
{ writeln('** getPartition: ', blkNo, ' ', partNo mod PartsPerBlock); }
|
||||
end;
|
||||
|
||||
procedure putPartition(var part:Partition; partNo:integer);
|
||||
var blkNo:integer;
|
||||
begin
|
||||
blkNo := partNo div PartsPerBlock;
|
||||
{ writeln('** putPartition: ', blkNo, ' ', partNo mod PartsPerBlock); }
|
||||
if (blkNo < 0) or (blkNo > LastPartBlock) then
|
||||
writeln('internal error: invalid part no in getPartition')
|
||||
else
|
||||
begin
|
||||
partTable[blkNo][partNo mod PartsPerBlock] := part;
|
||||
changed[blkNo] := true;
|
||||
end;
|
||||
end;
|
||||
|
||||
function isEmptyPart(var part:Partition):boolean;
|
||||
begin
|
||||
isEmptyPart := (part.startBlock = 0) and (part.blocks = 0);
|
||||
end;
|
||||
|
||||
procedure printPartTable;
|
||||
var blkNo, partNo:integer;
|
||||
partBlk:PartitionTableBlock;
|
||||
part:Partition;
|
||||
totalPartNo:integer;
|
||||
begin
|
||||
totalPartNo := 0;
|
||||
|
||||
writeln('Partition Table:');
|
||||
writeln('No. ', 'Flags':11, 'Name':32, 'Start':10, 'Size':10);
|
||||
|
||||
for blkNo := 0 to LastPartBlock do
|
||||
begin
|
||||
partBlk := partTable[blkNo];
|
||||
for partNo := 0 to PartsPerBlock - 1 do
|
||||
begin
|
||||
part := partBlk[partNo];
|
||||
|
||||
if not isEmptyPart(part) then
|
||||
begin
|
||||
write(totalPartNo:3, ': ', flags2Str(part.flags):11,
|
||||
sanitizeName(part.name):32,
|
||||
part.startBlock:10,
|
||||
part.blocks:10);
|
||||
if PartBoot in part.flags then write(' ', part.bootBlocks);
|
||||
writeln;
|
||||
lastPartNo := totalPartNo;
|
||||
end;
|
||||
totalPartNo := totalPartNo + 1;
|
||||
end;
|
||||
end;
|
||||
writeln('Flags: P=Physical B=Boot E=Enabled L=Last D=Default');
|
||||
end;
|
||||
|
||||
function askPartNo:integer;
|
||||
var i:integer;
|
||||
s:string;
|
||||
begin
|
||||
askPartNo := -1;
|
||||
write('Enter partition number (0-', lastPartNo, ')> ');
|
||||
readln(s);
|
||||
if length(s) > 0 then
|
||||
begin
|
||||
val(s,askPartNo,i);
|
||||
if i > 0 then
|
||||
writeln('Invalid partition number');
|
||||
end;
|
||||
end;
|
||||
|
||||
function askConfirmPartNo:integer;
|
||||
var partNo:integer;
|
||||
part:Partition;
|
||||
answer:char;
|
||||
begin
|
||||
askConfirmPartNo := -1;
|
||||
|
||||
partNo := askPartNo;
|
||||
|
||||
if partNo >= 0 then
|
||||
begin
|
||||
part := getPartition(partNo);
|
||||
write('Any data on partition ', partNo,
|
||||
' (', sanitizeName(part.name), ') ',
|
||||
'will be destroyed. Sure [y/n]? ');
|
||||
readln(answer);
|
||||
if upcase(answer) = 'Y' then
|
||||
askConfirmPartNo := partNo;
|
||||
end;
|
||||
end;
|
||||
|
||||
function guessExtentSize(blocks:integer):integer;
|
||||
begin
|
||||
if blocks >= 4194304 then (* 2 GB *)
|
||||
guessExtentSize := 1048576 (* use 1MB extents *)
|
||||
else
|
||||
if blocks >= 1048576 then (* 512 MB *)
|
||||
guessExtentSize := 524288 (* use 512K extents *)
|
||||
else
|
||||
if blocks >= 524288 then (* 256 MB *)
|
||||
guessExtentSize := 131072
|
||||
else
|
||||
if blocks >= 262144 then (* 128 MB *)
|
||||
guessExtentSize := 65536
|
||||
else
|
||||
if blocks >= 32768 then (* 16 MB *)
|
||||
guessExtentSize := 16384
|
||||
else
|
||||
guessExtentSize := 8192;
|
||||
end;
|
||||
|
||||
function getDirSize(extentSize,blocks:integer):integer;
|
||||
begin
|
||||
getDirSize := blocks div (extentSize div 512);
|
||||
end;
|
||||
|
||||
procedure createFilesystem(partNo:integer); forward;
|
||||
|
||||
procedure addVolume;
|
||||
var nextFreeBlock:integer;
|
||||
nextBlock:integer;
|
||||
extentSize:integer;
|
||||
size:integer;
|
||||
i:integer;
|
||||
part:Partition;
|
||||
maxBlocks:integer;
|
||||
freeBlocks:integer;
|
||||
newPartNo:integer;
|
||||
newPart:Partition;
|
||||
begin
|
||||
part := getPartition(0);
|
||||
maxBlocks := part.blocks;
|
||||
nextFreeBlock := 0;
|
||||
(* read all partitions *)
|
||||
for i := 1 to lastPartNo do
|
||||
begin
|
||||
part := getPartition(i);
|
||||
nextBlock := part.startBlock + part.blocks;
|
||||
if nextBlock > nextFreeBlock then
|
||||
nextFreeBlock := nextBlock;
|
||||
end;
|
||||
(* remember last used block *)
|
||||
writeln('next free partition: ', lastPartNo + 1,
|
||||
' next free block: ', nextFreeBlock);
|
||||
|
||||
freeBlocks := maxBlocks - nextFreeBlock;
|
||||
|
||||
if freeBlocks < 1 then
|
||||
writeln('Cannot add partition - no free blocks after last partition.')
|
||||
else
|
||||
begin
|
||||
newPartNo := lastPartNo + 1;
|
||||
(* remove last partition flag on previous last partition *)
|
||||
part.flags := part.flags - [PartLast];
|
||||
putPartition(part, lastPartNo);
|
||||
|
||||
(* create new partition *)
|
||||
size := freeBlocks;
|
||||
changeNumber('Size (blocks)', size);
|
||||
write('Name> ':30);
|
||||
readln(newPart.name);
|
||||
|
||||
newPart.startBlock := nextFreeBlock;
|
||||
newPart.blocks := size;
|
||||
newPart.extentSize := guessExtentSize(size);
|
||||
newPart.dirSize := getDirSize(newPart.extentSize, size);
|
||||
newPart.bootBlocks := 0;
|
||||
(* mark new partition as last partition *)
|
||||
newPart.flags := [ PartEnabled, PartLast ];
|
||||
putPartition(newPart, newPartNo);
|
||||
|
||||
writeln('Partition ', newPartNo, ' created, extent size:', newPart.extentSize,
|
||||
' directory size: ', newPart.dirSize);
|
||||
createFilesystem(newPartNo);
|
||||
|
||||
lastPartNo := lastPartNo + 1;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure renameVolume;
|
||||
var partNo:integer;
|
||||
newName:string;
|
||||
part:Partition;
|
||||
|
||||
begin
|
||||
partNo := askPartNo;
|
||||
if partNo >= 0 then
|
||||
begin
|
||||
part := getPartition(partNo);
|
||||
writeln('Old partition/volume name: ', sanitizeName(part.name));
|
||||
write('New partion/volume name: ');
|
||||
readln(newName);
|
||||
if length(newName) > 0 then
|
||||
begin
|
||||
part.name := newName;
|
||||
putPartition(part, partNo);
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure toggleDefaultFlag;
|
||||
var partNo:integer;
|
||||
part:Partition;
|
||||
|
||||
begin
|
||||
partNo := askPartNo;
|
||||
if partNo >= 0 then
|
||||
begin
|
||||
part := getPartition(partNo);
|
||||
write('Default flag ');
|
||||
if PartDefault in part.flags then
|
||||
begin
|
||||
part.flags := part.flags - [PartDefault];
|
||||
write('cleared');
|
||||
end
|
||||
else
|
||||
begin
|
||||
part.flags := part.flags + [PartDefault];
|
||||
write('set');
|
||||
end;
|
||||
writeln(' on partition ', partNo, ' (', sanitizeName(part.name), ').');
|
||||
putPartition(part, partNo);
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure deleteVolume;
|
||||
var partNo:integer;
|
||||
part:Partition;
|
||||
begin
|
||||
partNo := askConfirmPartNo;
|
||||
if partNo >= 0 then
|
||||
begin
|
||||
part := getPartition(partNo);
|
||||
part.flags := [];
|
||||
part.name := '';
|
||||
part.startBlock := 0;
|
||||
part.blocks := 0;
|
||||
part.extentSize := 0;
|
||||
part.dirSize := 0;
|
||||
part.bootBlocks := 0;
|
||||
putPartition(part, partNo);
|
||||
|
||||
writeln('Partition ', partNo, ' deleted.');
|
||||
|
||||
(* try to fix last partition flag *)
|
||||
(* only works if the previous entry has
|
||||
a valid partition *)
|
||||
if partNo = lastPartNo then
|
||||
begin
|
||||
lastPartNo := lastPartNo - 1;
|
||||
part := getPartition(lastPartNo);
|
||||
part.flags := part.flags + [PartLast];
|
||||
putPartition(part, lastPartNo);
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure validatePartTable;
|
||||
var partNo:integer;
|
||||
phys:Partition;
|
||||
part,part2:Partition;
|
||||
answer:char;
|
||||
p,p2:integer;
|
||||
valid:boolean;
|
||||
begin
|
||||
valid := true;
|
||||
|
||||
phys := getPartition(0);
|
||||
if not (PartPhysical in phys.flags) then
|
||||
begin
|
||||
writeln('PHYS partition missing, initialize card first!');
|
||||
exit;
|
||||
end;
|
||||
|
||||
if phys.blocks <> detectedCardSize then
|
||||
begin
|
||||
write('PHYS partition size does not match detected card size, fix? [y/n]');
|
||||
readln(answer);
|
||||
if upcase(answer) = 'Y' then
|
||||
begin
|
||||
phys.blocks := detectedCardSize;
|
||||
putPartition(phys,0);
|
||||
end
|
||||
else
|
||||
valid := false;
|
||||
end;
|
||||
|
||||
for p := 1 to lastPartNo do
|
||||
begin
|
||||
part := getPartition(p);
|
||||
if (part.startBlock < 0) or (part.startBlock + part.blocks > phys.blocks) then
|
||||
begin
|
||||
writeln('Partition ', p, ' outside of physical bounds.');
|
||||
valid := false;
|
||||
end;
|
||||
|
||||
if PartEnabled in part.flags then
|
||||
if part.dirSize <> getDirSize(part.extentSize, part.blocks) then
|
||||
begin
|
||||
write('Partition ', p, ' has an invalid directory size (is ');
|
||||
writeln(part.dirSize, ', should be ',
|
||||
getDirSize(part.extentSize, part.blocks), ').');
|
||||
valid := false;
|
||||
end;
|
||||
|
||||
for p2 := 1 to lastPartNo do
|
||||
begin
|
||||
part2 := getPartition(p2);
|
||||
if (p <> p2) then
|
||||
begin
|
||||
if ((part.startBlock >= part2.startBlock) and
|
||||
(part.startBlock < part2.startBlock + part2.blocks)) or
|
||||
((part2.startBlock > part.startBlock) and
|
||||
(part2.startBlock < part.startBlock + part.blocks))
|
||||
then
|
||||
begin
|
||||
writeln('Partition ',p ,' overlaps with partition ', p2);
|
||||
valid := false;
|
||||
end;
|
||||
|
||||
if (part.name = part2.name) and (p > p2) then
|
||||
begin
|
||||
writeln('Duplicate volume name ', part.name);
|
||||
valid := false;
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
write('Partition table is ');
|
||||
if not valid then write('in');
|
||||
writeln('valid.');
|
||||
end;
|
||||
|
||||
procedure checkNewCard; forward;
|
||||
|
||||
procedure initializeCard;
|
||||
var part:Partition;
|
||||
answer:char;
|
||||
p:integer;
|
||||
begin
|
||||
writeln('Initializing a card will create an empty partition table with');
|
||||
writeln('the standard PHYS and BOOT partitions.');
|
||||
write('This will likely destroy any data on the card - sure? [y/n] ');
|
||||
readln(answer);
|
||||
if upcase(answer) <> 'Y' then exit;
|
||||
|
||||
(* create PHYS partition using detectedcardblocks *)
|
||||
part.name := 'PHYS';
|
||||
part.startBlock := 0;
|
||||
part.blocks := detectedCardSize;
|
||||
part.flags := [PartPhysical];
|
||||
part.extentSize := 0;
|
||||
part.dirSize := 0;
|
||||
part.bootBlocks := 0;
|
||||
putPartition(part,0);
|
||||
|
||||
(* create BOOT partition without PartBoot flag *)
|
||||
part.name := 'BOOT';
|
||||
part.startBlock := 16; (* 16 possible partition blocks with 8 partitions each *)
|
||||
part.blocks := 8192 - 16; (* align first volume to 4MB *)
|
||||
part.flags := [PartBoot, PartLast];
|
||||
putPartition(part,1);
|
||||
|
||||
part.name := '';
|
||||
part.startBlock := 0;
|
||||
part.blocks := 0;
|
||||
part.flags := [];
|
||||
|
||||
for p := 2 to 7 do
|
||||
putPartition(part,p);
|
||||
|
||||
writeln('Empty partition table created.');
|
||||
end;
|
||||
|
||||
procedure createFilesystem(partNo:integer);
|
||||
var firstDirBlock:integer;
|
||||
slot:DirectorySlot;
|
||||
dirblk:DirBlock;
|
||||
dirblockCount:integer;
|
||||
metaSlotsCount:integer;
|
||||
dirSlotsPerBlock:integer;
|
||||
dirSlotsPerExtent:integer;
|
||||
part:Partition;
|
||||
ts:Timestamp;
|
||||
i,b:integer;
|
||||
error,devid:integer;
|
||||
begin
|
||||
devid := 0;
|
||||
ts := 0;
|
||||
|
||||
part := getPartition(partNo);
|
||||
firstDirBlock := part.startBlock;
|
||||
dirSlotsPerBlock := 512 div 64;
|
||||
dirSlotsPerExtent := part.extentSize div 64;
|
||||
dirblockCount := (part.dirSize - 1) div dirSlotsPerBlock + 1;
|
||||
metaSlotsCount := (part.dirSize - 1) div dirSlotsPerExtent + 1;
|
||||
|
||||
writeln('partition size: ', part.blocks);
|
||||
writeln('extent size: ', part.extentSize);
|
||||
writeln('directory size: ', part.dirSize);
|
||||
{ writeln('dirslots per extent:', dirSlotsPerExtent);
|
||||
writeln('dirblocks: ', dirblockCount);
|
||||
writeln('metaslots: ', metaSlotsCount);
|
||||
writeln('first dir block: ', firstDirBlock);
|
||||
}
|
||||
for b := firstDirBlock to firstDirBlock + dirblockCount - 1 do
|
||||
begin
|
||||
for i := 0 to dirSlotsPerBlock - 1 do
|
||||
begin
|
||||
if metaSlotsCount > 0 then
|
||||
begin
|
||||
(* write DIR/Reserved directory slots *)
|
||||
slot.name := 'DIR';
|
||||
slot.flags := [ SlotReserved ];
|
||||
metaSlotsCount := metaSlotsCount - 1;
|
||||
end
|
||||
else
|
||||
begin
|
||||
(* write Free + EndScan directory slots *)
|
||||
slot.name := '';
|
||||
slot.flags := [ SlotFree , SlotEndScan ];
|
||||
end;
|
||||
slot.sizeBytes := 0;
|
||||
slot.createTime := ts;
|
||||
slot.modTime := ts;
|
||||
slot.generation := 0;
|
||||
slot.owner := 0;
|
||||
|
||||
dirBlk[i] := slot;
|
||||
end;
|
||||
writedirblk(b, dirBlk, error, devid);
|
||||
if error > 0 then
|
||||
writeln('error writing block ', b, ': ', error);
|
||||
end;
|
||||
writeln('Volume ', part.name, ' initialized.');
|
||||
end;
|
||||
|
||||
procedure initializeVolume;
|
||||
var partNo:integer;
|
||||
part:Partition;
|
||||
begin
|
||||
partNo := askConfirmPartNo;
|
||||
if partNo >= 0 then
|
||||
begin
|
||||
part := getPartition(partNo);
|
||||
if not (PartEnabled in part.flags) then
|
||||
writeln('Wrong partition flags (must be Enabled)')
|
||||
else
|
||||
createFilesystem(partNo);
|
||||
end;
|
||||
end;
|
||||
|
||||
|
||||
procedure rawEdit;
|
||||
var partNo:integer;
|
||||
newName:string;
|
||||
part:Partition;
|
||||
buf:string;
|
||||
begin
|
||||
writeln('Raw editing partition entry - use caution!');
|
||||
|
||||
partNo := askPartNo;
|
||||
if partNo >= 0 then
|
||||
begin
|
||||
part := getPartition(partNo);
|
||||
writeln('Volume name: ', sanitizeName(part.name));
|
||||
write('Flags> ':30);
|
||||
readln(buf);
|
||||
if length(buf) > 0 then
|
||||
part.flags := str2flags(buf);
|
||||
changeNumber('Start block', part.startBlock);
|
||||
changeNumber('Size (blocks)', part.blocks);
|
||||
changeNumber('Extent size (blocks)', part.extentSize);
|
||||
changeNumber('Dir size (slots)', part.dirSize);
|
||||
changeNumber('Boot blocks', part.bootBlocks);
|
||||
|
||||
putPartition(part, partNo);
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure installBoot;
|
||||
var bootfile:file;
|
||||
name:string;
|
||||
part:Partition;
|
||||
partNo:integer;
|
||||
buf:IOBlock;
|
||||
b,blkCount:integer;
|
||||
devId:integer;
|
||||
error:integer;
|
||||
|
||||
procedure readWordsIntoBuf;
|
||||
var i:integer;
|
||||
w:integer;
|
||||
c1,c2,c3,c4:char;
|
||||
begin
|
||||
for i := 0 to 127 do
|
||||
begin
|
||||
if not eof(bootfile) then
|
||||
begin
|
||||
read(bootfile, c1, c2, c3, c4);
|
||||
w := (ord(c1) shl 24) or
|
||||
(ord(c2) shl 16) or
|
||||
(ord(c3) shl 8) or
|
||||
ord(c4);
|
||||
end
|
||||
else
|
||||
w := 0;
|
||||
buf[i] := w;
|
||||
end;
|
||||
end;
|
||||
|
||||
begin
|
||||
devId := 0; (* only one device supported *)
|
||||
partNo := 1; (* BOOT partition is always at position 1 *)
|
||||
|
||||
part := getPartition(partNo);
|
||||
if part.name <> 'BOOT' then
|
||||
begin
|
||||
writeln('No BOOT partition at position 1.');
|
||||
exit;
|
||||
end;
|
||||
|
||||
write('Boot file name> ');
|
||||
readln(name);
|
||||
if length(name) > 0 then
|
||||
begin
|
||||
open(bootfile, name, ModeReadonly);
|
||||
if IOResult(bootfile) <> 0 then
|
||||
writeln('Error opening file: ', ErrorStr(IOResult(bootfile)))
|
||||
else
|
||||
begin
|
||||
blkCount := filesize(bootfile) div 512 + 1;
|
||||
if blkCount > part.blocks then
|
||||
writeln('Boot partition too small, need ', blkCount)
|
||||
else
|
||||
begin
|
||||
part.bootBlocks := blkCount;
|
||||
if not (PartBoot in part.flags) then
|
||||
begin
|
||||
write('Boot flag set');
|
||||
writeln(' on partition ', partNo,
|
||||
' (', sanitizeName(part.name), ').');
|
||||
part.flags := part.flags + [PartBoot];
|
||||
end;
|
||||
putPartition(part, partNo);
|
||||
for b := 0 to blkCount - 1 do
|
||||
begin
|
||||
readWordsIntoBuf;
|
||||
writeblock(part.startBlock + b, buf, error, devId);
|
||||
if error <> 0 then
|
||||
writeln('Error in writeblock ', b, ': ', error);
|
||||
end;
|
||||
writeln(blkCount, ' boot blocks written.');
|
||||
end;
|
||||
close(bootfile);
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure showMenu;
|
||||
begin
|
||||
writeln;
|
||||
writeln('L)ist partitions V)alidate partition table T)oggle default volume flag');
|
||||
writeln('A)dd volume R)ename volume D)elete volume I)nitialize volume');
|
||||
writeln('Read N)ew card Initialize C)ard');
|
||||
writeln('E)dit partition Install B)oot file eX)it');
|
||||
write('> ');
|
||||
end;
|
||||
|
||||
procedure invalidCommand;
|
||||
begin
|
||||
writeln('Invalid command.');
|
||||
end;
|
||||
|
||||
procedure command(cmd:char; var done:boolean);
|
||||
begin
|
||||
case cmd of
|
||||
'L': printPartTable;
|
||||
'A': addVolume;
|
||||
'R': renameVolume;
|
||||
'D': deleteVolume;
|
||||
'V': validatePartTable;
|
||||
'T': toggleDefaultFlag;
|
||||
'I': initializeVolume;
|
||||
'N': checkNewCard;
|
||||
'C': initializeCard;
|
||||
'B': installBoot;
|
||||
'E': rawEdit;
|
||||
'X',#24: done := true;
|
||||
else invalidCommand;
|
||||
end;
|
||||
end;
|
||||
|
||||
function changesPending:boolean;
|
||||
var i:integer;
|
||||
begin
|
||||
changesPending := false;
|
||||
for i := 0 to LastPartBlock do
|
||||
if changed[i] then changesPending := true;
|
||||
end;
|
||||
|
||||
procedure checkNewCard;
|
||||
begin
|
||||
if changesPending then
|
||||
writeln('WARNING: Discarding partition table changes.');
|
||||
initDevices;
|
||||
detectedCardSize := cardsize;
|
||||
writeln('Detected card size: ', detectedCardSize);
|
||||
readPartTable;
|
||||
printPartTable;
|
||||
end;
|
||||
|
||||
begin
|
||||
checkNewCard;
|
||||
|
||||
repeat
|
||||
showMenu;
|
||||
read(cmd);
|
||||
writeln;
|
||||
command(Upcase(cmd), done);
|
||||
until done;
|
||||
writePartitions;
|
||||
end.
|
||||
221
progs/reclaim.pas
Normal file
221
progs/reclaim.pas
Normal file
|
|
@ -0,0 +1,221 @@
|
|||
(* Copyright 2021-2024 Sebastian Lederer. See the file LICENSE.md for details *)
|
||||
program reclaim;
|
||||
var volname:string;
|
||||
ch:char;
|
||||
count:integer;
|
||||
|
||||
(* we use some stuff internal to stdlib.pas *)
|
||||
procedure getdirslot(volumeid:integer;slotNo:integer;var result:DirectorySlot;var error:integer);
|
||||
external;
|
||||
procedure putdirslot(volumeid:integer;slotNo:integer;var dirslot:DirectorySlot;var error:integer);
|
||||
external;
|
||||
|
||||
procedure scanVolume(volname:string;dryrun:boolean;verbose:boolean;var reclaimCount:integer);
|
||||
var volid:integer;
|
||||
i:integer;
|
||||
error:integer;
|
||||
dirslot:DirectorySlot;
|
||||
done:boolean;
|
||||
fileCount, deletedCount:integer;
|
||||
freeCount:integer;
|
||||
fileSlotCount:integer;
|
||||
reservedCount:integer;
|
||||
freeAreaCount:integer;
|
||||
inFreeArea:boolean;
|
||||
endSlot:integer;
|
||||
lastUsed:integer;
|
||||
deletedExtent:boolean;
|
||||
|
||||
procedure clearDirSlot;
|
||||
begin
|
||||
reclaimCount := reclaimCount + 1;
|
||||
|
||||
if not dryrun then
|
||||
begin
|
||||
dirslot.name := '';
|
||||
dirslot.flags := [SlotFree];
|
||||
dirslot.sizeBytes := 0;
|
||||
dirslot.createTime := 0;
|
||||
dirslot.modTime := 0;
|
||||
dirslot.generation := 0;
|
||||
|
||||
putdirslot(volid, i, dirslot, error);
|
||||
if error <> IONoError then
|
||||
begin
|
||||
write('Error writing directory slot ',i);
|
||||
writeln(': ', ErrorStr(error));
|
||||
done := true;
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure markLastSlot;
|
||||
var slotNo:integer;
|
||||
begin
|
||||
(* we actually mark the slot after the last used slot *)
|
||||
if not dryrun then
|
||||
begin
|
||||
if lastUsed < endSlot then
|
||||
begin
|
||||
writeln('Updating directory...');
|
||||
slotNo := lastUsed + 1;
|
||||
getdirslot(volid, slotNo, dirslot, error);
|
||||
if error <> IONoError then
|
||||
begin
|
||||
write('Error reading directory slot ', slotNo);
|
||||
writeln(': ', ErrorStr(error));
|
||||
end;
|
||||
|
||||
if not (SlotEndScan in dirslot.flags) then
|
||||
dirslot.flags := dirslot.flags + [SlotEndScan];
|
||||
|
||||
putdirslot(volid, slotNo, dirslot, error);
|
||||
if error <> IONoError then
|
||||
begin
|
||||
write('Error writing directory slot ', lastUsed);
|
||||
writeln(': ', ErrorStr(error));
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure beginFreeArea;
|
||||
begin
|
||||
freeCount := freeCount + 1;
|
||||
if not inFreeArea then
|
||||
begin
|
||||
inFreeArea := true;
|
||||
freeAreaCount := freeAreaCount + 1;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure endFreeArea;
|
||||
begin
|
||||
if inFreeArea then
|
||||
inFreeArea := false;
|
||||
end;
|
||||
|
||||
begin
|
||||
volid := findvolume(volname);
|
||||
if volid < 1 then
|
||||
writeln('Volume ', volname, ' not found.')
|
||||
else
|
||||
begin
|
||||
done := false;
|
||||
deletedExtent := false;
|
||||
inFreeArea := false;
|
||||
fileCount := 0;
|
||||
deletedCount := 0;
|
||||
reclaimCount := 0;
|
||||
freeCount := 0;
|
||||
reservedCount := 0;
|
||||
fileSlotCount := 0;
|
||||
freeAreaCount := 0;
|
||||
lastUsed := 0;
|
||||
|
||||
openvolumeid(volid);
|
||||
i := volumeTable[volid].startSlot;
|
||||
endSlot := volumeTable[volid].part.dirSize - 1;
|
||||
|
||||
if verbose then
|
||||
begin
|
||||
write('Volume ', volname);
|
||||
write(' start slot:', i);
|
||||
write(' dir size: ', endSlot + 1);
|
||||
writeln(' extent size: ', volumeTable[volid].part.extentSize);
|
||||
end;
|
||||
|
||||
writeln('Reading directory...');
|
||||
repeat
|
||||
getdirslot(volid, i, dirslot, error);
|
||||
if error <> IONoError then
|
||||
begin
|
||||
write('Error reading directory slot ',i);
|
||||
writeln(': ', ErrorStr(error));
|
||||
done := true;
|
||||
end
|
||||
else
|
||||
begin
|
||||
if SlotEndScan in dirslot.flags then
|
||||
done := true;
|
||||
if SlotFirst in dirslot.flags then
|
||||
begin
|
||||
lastUsed := i;
|
||||
fileCount := fileCount + 1;
|
||||
deletedExtent := false;
|
||||
endFreeArea;
|
||||
end
|
||||
else
|
||||
if SlotDeleted in dirslot.flags then
|
||||
begin
|
||||
deletedCount := deletedCount + 1;
|
||||
deletedExtent := true;
|
||||
clearDirSlot;
|
||||
(* we consider a deleted file
|
||||
as a free area here *)
|
||||
if not dryrun then
|
||||
beginFreeArea;
|
||||
end
|
||||
else
|
||||
if SlotExtent in dirslot.flags then
|
||||
begin
|
||||
if deletedExtent then
|
||||
clearDirSlot
|
||||
else
|
||||
lastUsed := i;
|
||||
end
|
||||
else
|
||||
if SlotReserved in dirslot.flags then
|
||||
reservedCount := reservedCount + 1
|
||||
else
|
||||
if SlotFree in dirslot.flags then
|
||||
beginFreeArea;
|
||||
end;
|
||||
if i = endSlot then
|
||||
done := true;
|
||||
i := i + 1;
|
||||
until done;
|
||||
|
||||
markLastSlot;
|
||||
closevolumeid(volid);
|
||||
i := i - 1;
|
||||
|
||||
if verbose then
|
||||
begin
|
||||
writeln('last used slot: ', lastUsed);
|
||||
writeln('max slots: ', endSlot + 1);
|
||||
writeln('free slots: ', endSlot - i + freeCount);
|
||||
writeln('reserved slots: ', reservedCount);
|
||||
writeln;
|
||||
end;
|
||||
|
||||
write(fileCount, ' files, ', deletedCount, ' deleted files, ');
|
||||
write(reclaimCount);
|
||||
if dryrun then
|
||||
writeln(' reclaimable slots, ', freeAreaCount, ' free regions.')
|
||||
else
|
||||
writeln(' reclaimed slots, ', freeAreaCount, ' free regions.');
|
||||
end;
|
||||
end;
|
||||
|
||||
begin
|
||||
if ParamCount > 0 then
|
||||
volname := ParamStr(1)
|
||||
else
|
||||
begin
|
||||
write('Volume name> ');
|
||||
readln(volname);
|
||||
end;
|
||||
|
||||
initDevices;
|
||||
scanVolume(volname, true, true, count);
|
||||
|
||||
if count > 0 then
|
||||
begin
|
||||
write('Proceed with reclaim (y/n)? ');
|
||||
read(ch);
|
||||
writeln;
|
||||
if upcase(ch) = 'Y' then
|
||||
scanVolume(volname, false, false, count);
|
||||
end;
|
||||
end.
|
||||
481
progs/shell.pas
Normal file
481
progs/shell.pas
Normal file
|
|
@ -0,0 +1,481 @@
|
|||
(* Copyright 2021-2024 Sebastian Lederer. See the file LICENSE.md for details *)
|
||||
program shell;
|
||||
const EDITORPROG = '#SYSTEM:editor.prog';
|
||||
COMPILERPROG = '#SYSTEM:pcomp.prog';
|
||||
ASMPROG = '#SYSTEM:sasm.prog';
|
||||
RECLAIMPROG = '#SYSTEM:reclaim.prog';
|
||||
|
||||
const PageMargin = 3;
|
||||
MenuHeight = 6;
|
||||
|
||||
var cmd:char;
|
||||
ShellWorkfile:pathnamestr external;
|
||||
ShellCmd:string[40] external;
|
||||
ShellArg:integer external;
|
||||
|
||||
procedure checkClock;
|
||||
var line:string;
|
||||
digits:string[4];
|
||||
error:integer;
|
||||
yy,mm,dd,h,m,s:integer;
|
||||
isValid:boolean;
|
||||
|
||||
function lineIsValid:boolean;
|
||||
var c:char;
|
||||
begin
|
||||
lineIsValid := false;
|
||||
|
||||
if length(line) = 14 then
|
||||
begin
|
||||
for c in line do
|
||||
if not isDigit(c) then
|
||||
break;
|
||||
lineIsValid := true;
|
||||
end;
|
||||
end;
|
||||
|
||||
function isInRange(v,lo,hi:integer):boolean;
|
||||
begin
|
||||
isInRange := (v>=lo) and (v<=hi);
|
||||
end;
|
||||
|
||||
begin
|
||||
if SysClock.year = 0 then
|
||||
begin
|
||||
writeln('System clock not set - please enter date and time:');
|
||||
repeat
|
||||
isValid := false;
|
||||
write('YYYYMMDDHHMMSS> ');
|
||||
readln(line);
|
||||
|
||||
if lineIsValid then
|
||||
begin
|
||||
isValid := true;
|
||||
digits := copy(line,1,4);
|
||||
val(digits, yy, error);
|
||||
isValid := isValid and isInRange(yy, 1950, 3000);
|
||||
|
||||
digits := copy(line,5,2);
|
||||
val(digits, mm, error);
|
||||
isValid := isValid and isInRange(mm, 1, 12);
|
||||
|
||||
digits := copy(line,7,2);
|
||||
val(digits, dd, error);
|
||||
isValid := isValid and isInRange(dd, 1, 31);
|
||||
|
||||
digits := copy(line,9,2);
|
||||
val(digits, h, error);
|
||||
isValid := isValid and isInRange(h, 0, 23);
|
||||
|
||||
digits := copy(line,11,2);
|
||||
val(digits, m, error);
|
||||
isValid := isValid and isInRange(m, 0, 59);
|
||||
|
||||
digits := copy(line,13,2);
|
||||
val(digits, s, error);
|
||||
isValid := isValid and isInRange(s, 0, 59);
|
||||
end;
|
||||
until isValid;
|
||||
|
||||
SysClock.year := yy;
|
||||
SysClock.month := mm;
|
||||
SysClock.day := dd;
|
||||
SysClock.hours := h;
|
||||
SysClock.minutes := m;
|
||||
SysClock.seconds := s;
|
||||
|
||||
writeln('System clock is ', DateStr(SysClock), ' ', TimeStr(SysClock, true));
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure writew(s:string;width:integer);
|
||||
var w,i:integer;
|
||||
begin
|
||||
write(s);
|
||||
w := width - length(s);
|
||||
if w > 0 then
|
||||
for i := 1 to w do
|
||||
write(' ');
|
||||
end;
|
||||
|
||||
procedure splitFilename(var n:filenamestr;
|
||||
var basename:filenamestr;var extension:filenamestr);
|
||||
var i:integer;
|
||||
begin
|
||||
for i := length(n) downto 1 do
|
||||
begin
|
||||
if n[i] = '.' then
|
||||
break;
|
||||
end;
|
||||
if i > 1 then
|
||||
begin
|
||||
basename := copy(n, 1, i - 1);
|
||||
extension := copy(n, i, length(n) - i + 1);
|
||||
{ writeln('** splitFilename ',basename, ' ', extension); }
|
||||
end
|
||||
else
|
||||
begin
|
||||
basename := n;
|
||||
extension := '';
|
||||
end;
|
||||
end;
|
||||
|
||||
function replaceExtension(var n:pathnamestr; newExt:filenamestr):pathnamestr;
|
||||
var basename:filenamestr;
|
||||
ext:filenamestr;
|
||||
begin
|
||||
splitFilename(n, basename, ext);
|
||||
replaceExtension := basename + newExt;
|
||||
end;
|
||||
|
||||
procedure waitForKey; forward;
|
||||
|
||||
procedure listDirectory;
|
||||
var volid:integer;
|
||||
error:integer;
|
||||
index:integer;
|
||||
dirs:DirectorySlot;
|
||||
ftime:DateTime;
|
||||
screenW,screenH:integer;
|
||||
count:integer;
|
||||
begin
|
||||
GetTermSize(screenW, screenH);
|
||||
|
||||
volid := findvolume(DefaultVolume);
|
||||
if volid < 1 then
|
||||
writeln('Volume ', DefaultVolume, ' not found.')
|
||||
else
|
||||
begin
|
||||
count := PageMargin;
|
||||
|
||||
writeln('reading directory of ', DefaultVolume);
|
||||
openvolumeid(volid);
|
||||
readdirfirst(volid, index, dirs, error);
|
||||
while index > 0 do
|
||||
begin
|
||||
if dirs.modTime = 0 then
|
||||
begin
|
||||
ftime.year := 1970;
|
||||
ftime.month := 1;
|
||||
ftime.day := 1;
|
||||
ftime.hours := 0;
|
||||
ftime.minutes := 0;
|
||||
ftime.seconds := 0;
|
||||
end
|
||||
else
|
||||
ftime := GetDateTime(dirs.modTime);
|
||||
writew(dirs.name, 34);
|
||||
writew(DateStr(ftime) + ' ' + TimeStr(ftime,false), 22);
|
||||
writeln(dirs.sizeBytes:12, ' ', dirs.generation);
|
||||
|
||||
count := count + 1;
|
||||
if count >= screenH then
|
||||
begin
|
||||
count := PageMargin;
|
||||
waitForKey;
|
||||
end;
|
||||
|
||||
readdirnext(volid, index, dirs, error);
|
||||
end;
|
||||
closevolumeid(volid);
|
||||
|
||||
if count + MenuHeight >= screenH then
|
||||
waitForKey;
|
||||
end;
|
||||
end;
|
||||
|
||||
function volumeExists(var n:volumenamestr):boolean;
|
||||
var volid:integer;
|
||||
begin
|
||||
volid := findvolume(n);
|
||||
if volid < 1 then
|
||||
volumeExists := false
|
||||
else
|
||||
begin
|
||||
closevolumeid(volid);
|
||||
volumeExists := true;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure listVolumes;
|
||||
var i:integer;
|
||||
begin
|
||||
InitDevices;
|
||||
writeln('Available volumes:');
|
||||
for i := 1 to VolumeCount do
|
||||
writeln(VolumeTable[i].part.name);
|
||||
end;
|
||||
|
||||
procedure changeVolume;
|
||||
var n:volumenamestr;
|
||||
begin
|
||||
listVolumes;
|
||||
write('Enter volume name: ');
|
||||
readln(n);
|
||||
if length(n) > 0 then
|
||||
if volumeExists(n) then
|
||||
SetDefaultVolume(n)
|
||||
else
|
||||
writeln('Volume ', n , ' not found.');
|
||||
end;
|
||||
|
||||
procedure removeFile;
|
||||
var n:filenamestr;
|
||||
error:integer;
|
||||
begin
|
||||
write('File to delete: ');
|
||||
readln(n);
|
||||
|
||||
if length(n) > 0 then
|
||||
begin
|
||||
erase(n, error);
|
||||
|
||||
if error <> 0 then
|
||||
writeln('Error deleting ', n, ': ', ErrorStr(error));
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure renameFile;
|
||||
var n1,n2:filenamestr;
|
||||
error:integer;
|
||||
begin
|
||||
write('File to rename: ');
|
||||
readln(n1);
|
||||
write('New name: ');
|
||||
readln(n2);
|
||||
rename(n1, n2, error);
|
||||
|
||||
if error <> 0 then
|
||||
writeln('Error renaming ', n1, ': ', ErrorStr(error));
|
||||
end;
|
||||
|
||||
procedure copyFile;
|
||||
var n1,n2:filenamestr;
|
||||
error:integer;
|
||||
src,dst:file;
|
||||
ch:char;
|
||||
count:integer;
|
||||
begin
|
||||
write('File to copy: ');
|
||||
readln(n1);
|
||||
write('New file name: ');
|
||||
readln(n2);
|
||||
|
||||
open(src, n1, ModeReadonly);
|
||||
if IOResult(src) <> 0 then
|
||||
begin
|
||||
writeln('Error opening ', n1, ': ', ErrorStr(IOResult(src)));
|
||||
exit;
|
||||
end;
|
||||
|
||||
open(dst, n2, ModeCreate);
|
||||
if IOResult(dst) <> 0 then
|
||||
begin
|
||||
writeln('Error opening ', n2, ': ', ErrorStr(IOResult(dst)));
|
||||
close(src);
|
||||
exit;
|
||||
end;
|
||||
|
||||
write('Copying ',n1, ' to ', n2, '...');
|
||||
count := 0;
|
||||
while not eof(src) do
|
||||
begin
|
||||
read(src,ch); (* not efficient but keep it simple *)
|
||||
write(dst,ch);
|
||||
count := count + 1;
|
||||
if (count and 8191) = 0 then write('.');
|
||||
end;
|
||||
|
||||
close(dst);
|
||||
close(src);
|
||||
|
||||
writeln;
|
||||
end;
|
||||
|
||||
procedure setWorkfile;
|
||||
var n:filenamestr;
|
||||
begin
|
||||
write('Enter workfile name: ');
|
||||
readln(n);
|
||||
|
||||
ShellWorkfile := n;
|
||||
ShellCmd := '';
|
||||
ShellArg := 0;
|
||||
end;
|
||||
|
||||
procedure requireWorkfile;
|
||||
begin
|
||||
while length(ShellWorkFile) = 0 do
|
||||
setWorkfile;
|
||||
end;
|
||||
|
||||
procedure edit(gotoLine:integer);
|
||||
var error:integer;
|
||||
digits:string[10];
|
||||
args:PArgVec;
|
||||
begin
|
||||
requireWorkfile;
|
||||
if gotoLine > 0 then
|
||||
begin
|
||||
str(gotoLine,digits);
|
||||
args[0] := '-l';
|
||||
args[1] := digits;
|
||||
args[2] := ShellWorkFile;
|
||||
PExec(EDITORPROG, args, 3, error);
|
||||
end
|
||||
else
|
||||
PExec2(EDITORPROG, ShellWorkFile, error);
|
||||
writeln('PExec error ', error);
|
||||
end;
|
||||
|
||||
procedure assemble;
|
||||
var filename:filenamestr;
|
||||
error:integer;
|
||||
begin
|
||||
requireWorkfile;
|
||||
filename := replaceExtension(ShellWorkFile, '.s');
|
||||
PExec2(ASMPROG, filename, error);
|
||||
writeln('PExec error ', error);
|
||||
end;
|
||||
|
||||
procedure compile;
|
||||
var filename:filenamestr;
|
||||
error:integer;
|
||||
begin
|
||||
requireWorkfile;
|
||||
filename := replaceExtension(ShellWorkFile, '.pas');
|
||||
PExec3(COMPILERPROG, '-S', filename, error);
|
||||
writeln('PExec error ', error);
|
||||
end;
|
||||
|
||||
procedure build;
|
||||
var filename:filenamestr;
|
||||
error:integer;
|
||||
begin
|
||||
requireWorkfile;
|
||||
filename := replaceExtension(ShellWorkFile, '.pas');
|
||||
PExec2(COMPILERPROG, filename, error);
|
||||
writeln('PExec error ', error);
|
||||
end;
|
||||
|
||||
procedure run;
|
||||
var args:PArgVec;
|
||||
error:integer;
|
||||
prgname:pathnamestr;
|
||||
begin
|
||||
requireWorkfile;
|
||||
prgname := replaceExtension(ShellWorkfile, '.prog');
|
||||
writeln('Running ', prgname);
|
||||
PExec(prgname, args, 0, error);
|
||||
writeln('Pexec failed, error ', error);
|
||||
end;
|
||||
|
||||
procedure krunch;
|
||||
var error:integer;
|
||||
begin
|
||||
PExec2(RECLAIMPROG, DefaultVolume, error);
|
||||
writeln('PExec error ', error);
|
||||
end;
|
||||
|
||||
procedure runProgram;
|
||||
var args:PArgVec;
|
||||
argCount:integer;
|
||||
error:integer;
|
||||
prgname:pathnamestr;
|
||||
a:string;
|
||||
begin
|
||||
write('Enter program file name: ');
|
||||
readln(prgname);
|
||||
|
||||
if length(prgname) > 0 then
|
||||
begin
|
||||
if pos('.', prgname) = 0 then prgname := prgname + '.prog';
|
||||
|
||||
writeln('Enter program arguments line-by-line, empty line to finish.');
|
||||
|
||||
(* entering the arguments line by line is ugly, but it saves us from
|
||||
the hassle of dealing with word boundary detection and quoting *)
|
||||
argCount := 0;
|
||||
repeat
|
||||
write('arg ', argCount + 1, ': ');
|
||||
readln(a);
|
||||
if length(a) > 0 then
|
||||
begin
|
||||
args[argCount] := a;
|
||||
argCount := argCount + 1;
|
||||
end;
|
||||
until (length(a) = 0) or (argCount > PArgMax);
|
||||
|
||||
writeln('Running ', prgname);
|
||||
PExec(prgname, args, argCount, error);
|
||||
writeln('Pexec failed, error ', error);
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure showMenu;
|
||||
begin
|
||||
writeln;
|
||||
writeln('W)orkfile: ', ShellWorkfile);
|
||||
writeln('V)olume: ', DefaultVolume);
|
||||
writeln('L)ist directory K)runch volume O)ther program');
|
||||
writeln('D)elete file RenaM)e file coP)y file');
|
||||
writeln('E)dit C)ompile A)ssemble B)uild R)un');
|
||||
write('> ');
|
||||
end;
|
||||
|
||||
procedure command(cmd:char;arg:integer);
|
||||
begin
|
||||
case cmd of
|
||||
'L': listDirectory;
|
||||
'V': changeVolume;
|
||||
'W': setWorkfile;
|
||||
'R': run;
|
||||
'A': assemble;
|
||||
'C': compile;
|
||||
'B': build;
|
||||
'E': edit(arg);
|
||||
'D': removeFile;
|
||||
'M': renameFile;
|
||||
'P': copyFile;
|
||||
'K': krunch;
|
||||
'O': runProgram;
|
||||
else ;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure waitForKey;
|
||||
var c:char;
|
||||
begin
|
||||
writeln;
|
||||
writeln('-- press any key to continue --');
|
||||
c := conin;
|
||||
end;
|
||||
|
||||
begin
|
||||
if length(DefaultVolume) = 0 then
|
||||
SetDefaultVolume('SYSTEM');
|
||||
|
||||
checkClock;
|
||||
|
||||
if length(ShellCmd) > 0 then
|
||||
begin
|
||||
if ShellCmd[1] = 'W' then
|
||||
begin
|
||||
waitForKey;
|
||||
delete(Shellcmd,1,1);
|
||||
end;
|
||||
|
||||
if length(ShellCmd) > 0 then
|
||||
command(ShellCmd[1], ShellArg);
|
||||
|
||||
ShellCmd := '';
|
||||
end;
|
||||
|
||||
while true do
|
||||
begin
|
||||
showMenu;
|
||||
read(cmd);
|
||||
writeln;
|
||||
command(Upcase(cmd), ShellArg);
|
||||
end;
|
||||
end.
|
||||
431
progs/xfer.pas
Normal file
431
progs/xfer.pas
Normal file
|
|
@ -0,0 +1,431 @@
|
|||
(* Copyright 2021-2024 Sebastian Lederer. See the file LICENSE.md for details *)
|
||||
program xfer;
|
||||
|
||||
const CksumPattern = $AFFECAFE;
|
||||
SOH = #1;
|
||||
STX = #2;
|
||||
EOT = #4;
|
||||
ENQ = #5;
|
||||
ACK = #6;
|
||||
BEL = #7;
|
||||
NAK = #21;
|
||||
|
||||
TimeoutTicks = 200;
|
||||
|
||||
var blockNo:integer;
|
||||
buf:^string;
|
||||
invalid:boolean;
|
||||
cmd:char;
|
||||
filename:string;
|
||||
size:integer;
|
||||
done:boolean;
|
||||
xferFile:file;
|
||||
|
||||
function calcChksum(last,this:integer):integer;
|
||||
begin
|
||||
calcChksum := ((last + this) xor CksumPattern) shl 1;
|
||||
end;
|
||||
|
||||
function readword:integer;
|
||||
var b3,b2,b1,b0:char;
|
||||
begin
|
||||
b3 := conin;
|
||||
b2 := conin;
|
||||
b1 := conin;
|
||||
b0 := conin;
|
||||
|
||||
readword := (ord(b3) shl 24) or
|
||||
(ord(b2) shl 16) or
|
||||
(ord(b1) shl 8) or
|
||||
ord(b0);
|
||||
end;
|
||||
|
||||
procedure serReadBlock(var success:boolean);
|
||||
var w0,w1,w2,w3,w4,w5,w6,w7,w8:integer;
|
||||
chksum:integer;
|
||||
s:integer;
|
||||
|
||||
procedure writeByte(b:char);
|
||||
begin
|
||||
if size <> 0 then
|
||||
begin
|
||||
write(xferFile,b);
|
||||
size := size - 1;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure appendWordToFile(w:integer);
|
||||
var b3,b2,b1,b0:char;
|
||||
begin
|
||||
b0 := chr(w and 255);
|
||||
w := w shr 8;
|
||||
|
||||
b1 := chr(w and 255);
|
||||
w := w shr 8;
|
||||
|
||||
b2 := chr(w and 255);
|
||||
w := w shr 8;
|
||||
|
||||
b3 := chr(w);
|
||||
|
||||
writeByte(b3);
|
||||
writeByte(b2);
|
||||
writeByte(b1);
|
||||
writeByte(b0);
|
||||
end;
|
||||
|
||||
procedure calcChksum(d:integer);
|
||||
begin
|
||||
chksum := ((chksum + d) xor CksumPattern) shl 1;
|
||||
end;
|
||||
|
||||
begin
|
||||
chksum := 0;
|
||||
|
||||
w0 := readword;
|
||||
w1 := readword;
|
||||
w2 := readword;
|
||||
w3 := readword;
|
||||
w4 := readword;
|
||||
w5 := readword;
|
||||
w6 := readword;
|
||||
w7 := readword;
|
||||
|
||||
s := readword;
|
||||
|
||||
calcChksum(w0);
|
||||
calcChksum(w1);
|
||||
calcChksum(w2);
|
||||
calcChksum(w3);
|
||||
calcChksum(w4);
|
||||
calcChksum(w5);
|
||||
calcChksum(w6);
|
||||
calcChksum(w7);
|
||||
|
||||
if s <> chksum then
|
||||
begin
|
||||
success := false;
|
||||
write(NAK);
|
||||
{ writeln('invalid chksum ', s, ' ', chksum); }
|
||||
end
|
||||
else
|
||||
begin
|
||||
success := true;
|
||||
appendWordToFile(w0);
|
||||
appendWordToFile(w1);
|
||||
appendWordToFile(w2);
|
||||
appendWordToFile(w3);
|
||||
appendWordToFile(w4);
|
||||
appendWordToFile(w5);
|
||||
appendWordToFile(w6);
|
||||
appendWordToFile(w7);
|
||||
blockNo := blockNo + 1;
|
||||
write(ACK);
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure waitForByte(var byteReceived:char; var timeoutReached:boolean);
|
||||
var ticks:integer;
|
||||
done:boolean;
|
||||
begin
|
||||
timeoutReached := true;
|
||||
ticks := getticks;
|
||||
done := false;
|
||||
|
||||
repeat
|
||||
if conavail then
|
||||
begin
|
||||
done := true;
|
||||
timeoutReached := false;
|
||||
byteReceived := conin;
|
||||
end;
|
||||
until done or (getticks > ticks + TimeoutTicks);
|
||||
end;
|
||||
|
||||
procedure waitForHeader(var invalid:boolean);
|
||||
var done:boolean;
|
||||
timedOut:boolean;
|
||||
ch:char;
|
||||
begin
|
||||
waitForByte(ch, timedOut);
|
||||
invalid := (ch <> STX) or timedOut;
|
||||
end;
|
||||
|
||||
procedure receiveHeader(var invalid:boolean);
|
||||
var ch:char;
|
||||
timedOut:boolean;
|
||||
w:integer;
|
||||
cksum:integer;
|
||||
begin
|
||||
{ send protocol version, then wait for size header }
|
||||
write('1');
|
||||
|
||||
waitForByte(ch, timedOut);
|
||||
if timedOut or (ch <> SOH) then
|
||||
begin
|
||||
invalid := true;
|
||||
exit;
|
||||
end;
|
||||
|
||||
cksum := 0;
|
||||
|
||||
w := readword;
|
||||
cksum := readword;
|
||||
|
||||
if w <> (not cksum) then
|
||||
begin
|
||||
write(NAK);
|
||||
w := 0;
|
||||
writeln('h chksum error');
|
||||
end
|
||||
else
|
||||
write(ACK);
|
||||
|
||||
if w > 0 then
|
||||
begin
|
||||
size := w;
|
||||
waitForHeader(invalid);
|
||||
end
|
||||
else
|
||||
invalid := true;
|
||||
end;
|
||||
|
||||
procedure receiveFile;
|
||||
var ch:char;
|
||||
invalid, timedOut:boolean;
|
||||
ok:boolean;
|
||||
done:boolean;
|
||||
errorCount:integer;
|
||||
begin
|
||||
if length(filename) = 0 then
|
||||
begin
|
||||
writeln('Filename not set.');
|
||||
exit;
|
||||
end;
|
||||
|
||||
errorCount := 0;
|
||||
|
||||
waitForByte(ch, timedOut);
|
||||
if timedOut then
|
||||
begin
|
||||
writeln('Timeout waiting for transmission start (ENQ or STX).');
|
||||
exit;
|
||||
end;
|
||||
|
||||
if ch = ENQ then
|
||||
receiveHeader(invalid)
|
||||
else
|
||||
if ch = STX then
|
||||
begin
|
||||
size := -1;
|
||||
invalid := false;
|
||||
end
|
||||
else
|
||||
invalid := true;
|
||||
|
||||
if not invalid then
|
||||
begin
|
||||
open(xferFile, filename, ModeOverwrite);
|
||||
done := false;
|
||||
repeat
|
||||
serReadBlock(ok);
|
||||
if not ok then errorCount := errorCount + 1;
|
||||
|
||||
waitForByte(ch, timedOut);
|
||||
if timedOut then
|
||||
writeln('Timeout waiting for next block (STX)');
|
||||
if ch = EOT then
|
||||
done := true
|
||||
else
|
||||
if ch <> STX then
|
||||
begin
|
||||
writeln('Invalid header byte (expected STX)');
|
||||
done := true;
|
||||
end;
|
||||
until done or timedOut;
|
||||
|
||||
close(xferFile);
|
||||
|
||||
writeln(blockNo, ' blocks received, ', errorCount, ' checksum errors. ', ord(ch));
|
||||
end
|
||||
else
|
||||
writeln('Invalid or no header received.', size);
|
||||
end;
|
||||
|
||||
function getWordFromFile:integer;
|
||||
|
||||
function getCharFromFile:integer;
|
||||
var c:char;
|
||||
begin
|
||||
if size > 0 then
|
||||
begin
|
||||
read(xferFile,c);
|
||||
size := size - 1;
|
||||
end
|
||||
else
|
||||
c := #0;
|
||||
|
||||
getCharFromFile := ord(c);
|
||||
end;
|
||||
|
||||
begin
|
||||
getWordFromFile := getCharFromFile shl 8;
|
||||
getWordFromFile := (getWordFromFile or getCharFromFile) shl 8;
|
||||
getWordFromFile := (getWordFromFile or getCharFromFile) shl 8;
|
||||
getWordFromFile := (getWordFromFile or getCharFromFile);
|
||||
end;
|
||||
|
||||
procedure sendword(w:integer);
|
||||
var b3,b2,b1,b0:char;
|
||||
begin
|
||||
b0 := chr(w and 255);
|
||||
w := w shr 8;
|
||||
|
||||
b1 := chr(w and 255);
|
||||
w := w shr 8;
|
||||
|
||||
b2 := chr(w and 255);
|
||||
w := w shr 8;
|
||||
|
||||
b3 := chr(w and 255);
|
||||
|
||||
write(b3,b2,b1,b0);
|
||||
end;
|
||||
|
||||
procedure sendFile;
|
||||
var ch:char;
|
||||
w,cksum:integer;
|
||||
wordCount:integer;
|
||||
lastSize,lastPos:integer;
|
||||
timedOut:boolean;
|
||||
done:boolean;
|
||||
begin
|
||||
if length(filename) = 0 then
|
||||
begin
|
||||
writeln('Filename not set.');
|
||||
exit;
|
||||
end;
|
||||
|
||||
{ wait for start byte }
|
||||
ch := conin;
|
||||
if ch <> BEL then
|
||||
begin
|
||||
writeln('Invalid start character received.');
|
||||
exit;
|
||||
end;
|
||||
|
||||
open(xferFile, filename, ModeReadonly);
|
||||
if IOResult(xferFile) <> 0 then
|
||||
begin
|
||||
writeln('Error opening file: ', ErrorStr(IOResult(xferFile)));
|
||||
exit;
|
||||
end;
|
||||
|
||||
size := filesize(xferFile);
|
||||
done := false;
|
||||
|
||||
{ send size header: SOH, size word, inverted size word }
|
||||
write(SOH);
|
||||
sendword(size);
|
||||
sendword(not size);
|
||||
|
||||
{ check for ACK }
|
||||
waitForByte(ch, timedOut);
|
||||
|
||||
if timedOut then
|
||||
writeln('Timeout sending size header ')
|
||||
else
|
||||
if ch <> ACK then
|
||||
writeln('Error sending size header ', ord(ch))
|
||||
else
|
||||
repeat
|
||||
lastPos := filepos(xferFile);
|
||||
lastSize := size;
|
||||
|
||||
write(STX);
|
||||
{ send a block: STX, 8 words, checksum word }
|
||||
cksum := 0;
|
||||
for wordCount := 1 to 8 do
|
||||
begin
|
||||
w := getWordFromFile;
|
||||
cksum := calcChkSum(cksum, w);
|
||||
sendword(w);
|
||||
end;
|
||||
sendword(cksum);
|
||||
|
||||
{ check for ACK/NAK }
|
||||
waitForByte(ch, timedOut);
|
||||
if timedOut then
|
||||
begin
|
||||
writeln('Timeout waiting for ACK');
|
||||
done := true;
|
||||
end
|
||||
else
|
||||
if ch = NAK then
|
||||
begin
|
||||
seek(xferFile, lastPos);
|
||||
size := lastSize;
|
||||
end
|
||||
else
|
||||
if ch = ACK then
|
||||
begin
|
||||
if size = 0 then done := true;
|
||||
end
|
||||
else
|
||||
begin
|
||||
writeln('Invalid reply after sending block');
|
||||
done := true;
|
||||
end;
|
||||
until done;
|
||||
write(EOT);
|
||||
close(xferFile);
|
||||
end;
|
||||
|
||||
procedure setFilename;
|
||||
begin
|
||||
write('Filename> ');
|
||||
readln(filename);
|
||||
end;
|
||||
|
||||
procedure listDirectory;
|
||||
var volid:integer;
|
||||
error:integer;
|
||||
index:integer;
|
||||
dirs:DirectorySlot;
|
||||
begin
|
||||
volid := findvolume(DefaultVolume);
|
||||
if volid < 1 then
|
||||
writeln('Volume ', DefaultVolume, ' not found.')
|
||||
else
|
||||
begin
|
||||
openvolumeid(volid);
|
||||
readdirfirst(volid, index, dirs, error);
|
||||
while (index > 0) and (error = 0) do
|
||||
begin
|
||||
writeln(dirs.name);
|
||||
readdirnext(volid, index, dirs, error);
|
||||
end;
|
||||
end;
|
||||
writeln;
|
||||
end;
|
||||
|
||||
begin
|
||||
writeln('L) upload (receive) D) download (send).');
|
||||
writeln('S) set filename Y) directory X) exit');
|
||||
|
||||
done := false;
|
||||
|
||||
repeat
|
||||
write('> ');
|
||||
read(cmd);
|
||||
writeln;
|
||||
case upcase(cmd) of
|
||||
'L': receiveFile;
|
||||
'D': sendFile;
|
||||
'S': setFilename;
|
||||
'X': done := true;
|
||||
'Y': listDirectory;
|
||||
else writeln('?');
|
||||
end;
|
||||
until done;
|
||||
end.
|
||||
Loading…
Add table
Add a link
Reference in a new issue