481 lines
9.7 KiB
ObjectPascal
481 lines
9.7 KiB
ObjectPascal
(* 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
|
|
PExec1(EDITORPROG, ShellWorkFile, error);
|
|
writeln('PExec error ', error);
|
|
end;
|
|
|
|
procedure assemble;
|
|
var filename:filenamestr;
|
|
error:integer;
|
|
begin
|
|
requireWorkfile;
|
|
filename := replaceExtension(ShellWorkFile, '.s');
|
|
PExec1(ASMPROG, filename, error);
|
|
writeln('PExec error ', error);
|
|
end;
|
|
|
|
procedure compile;
|
|
var filename:filenamestr;
|
|
error:integer;
|
|
begin
|
|
requireWorkfile;
|
|
filename := replaceExtension(ShellWorkFile, '.pas');
|
|
PExec2(COMPILERPROG, '-S', filename, error);
|
|
writeln('PExec error ', error);
|
|
end;
|
|
|
|
procedure build;
|
|
var filename:filenamestr;
|
|
error:integer;
|
|
begin
|
|
requireWorkfile;
|
|
filename := replaceExtension(ShellWorkFile, '.pas');
|
|
PExec1(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
|
|
PExec1(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.
|