maclab@reed.UUCP (Mac DLab) (12/20/85)
Here is the Rascal source for SquirmTerm. It has quite a history
of changes, so it is a bit rats-nesty. Seems to do the trick, though.
----------------------------------------------------------------------------
Happy Holidays from the Reed Academic Software Development Laboratory!
Richard Crandall
Marianne Colgrove
Josh Doenias
Scott Gillespie
Michael McGreevy
Greg Stein (in absentia)
Ann Muir Thomas
and :-)
"I was dreaming about dogs." (Sarah)
{decvax, ucbvax, pur-ee, uw-beaver, masscomp, cbosg, aat,
mit-ems, psu-cs, uoregon, orstcs, ihnp4, uf-cgrl, ssc-vax}!tektronix
\
+--!reed!maclab
{teneron, ogcvax, muddcs, cadic, oresoft, grpwre, /
harvard, psu-cs, omen, isonvax, nsc-pdc}-------------+
------------------------------------------------------------------------------
program squirmterm;
(*
SQUIRMTERM IS A TERMINAL EMULATOR WITH MANY OPTIONS, AND SOME
vi SPECIFIC FEATURES. SEE THE FILE SquirmTerm.doc FOR DETAILS
OF OPERATION.
NEW ..... 85.04.08.spg
..... 85.10.21.spg -- added Uses, and cleaned up the code.
..... 85.12.18.spg -- Settings are remembered from session
to session.
*)
Uses __QuickTraps, __ToolTraps, __OSTraps, __LPR,
(*$U+*) uToolIntf, uOSIntf ;
Link __IO , __EasyMenus,
__Uniform , __SFnames, __OSTraps, __LPR : ;
Type
Settings = Record
Stops,
Parity,
Data,
Baud: Integer;
End;
SetHand = ^^Settings;
var
lheight,charw,
baud,zbaud,
parity,zparity,
stops,zstops,
data, zdata,
nocurse,rcfile,print,laserprint,RRef,NewRFile: integer;
seencr,rcv: byte;
rateblock: block[8];
myreply: block[80];
sfbitmap: block[14];
sfmyport,sfbits: ptrL;
utilrgn: ptrL;
rcbuf: block[1025];
rcbptr,
rcbsize: integer;
dbltime,lastclick,lastdbl:longint;
xxsize: block[8];
myrect: integer[4];
xxport: ptrL;
Function getvol(): Integer; (* Get the current default volume *)
var Param: ParamBlockRec;
err : OSErr;
{
Param.IOCompletion := 0;
Param.IONamePtr := 0;
err := PBGetVol(Param,False);
getvol := Param.IOVrefNum;
};
procedure setvol(vref: integer); (* Set the current default volume *)
var Param: ParamBlockRec;
err : OSErr;
{
Param.IOCompletion := 0;
Param.IONamePtr := 0;
Param.IOVrefNum := vref;
err := PBSetVol(Param,False);
};
Procedure InitSettings(); (* Get settings from resource file *)
Var
Name: Block[64];
myvol,oldvol,err: Integer;
S: SetHand;
{
stops:=1; parity:=5; data:=9; baud:=5 ; (* default settings *)
NewRFile := 0;
S := GetResource(PtrL(" SETT"+2)^,999); (* get the resource *)
If !S Then { (* the resource isn't there *)
RsrcRef(@RRef); (* get the reference number of squirmterm's file
*)
If RRef = -1 Then { (* there isn't a resource file yet *)
oldvol := GetVol();
applvref(@myvol);
setvol(myvol);
getwtitle(xxport,@Name);
CreateResFile(Name); (* create a resource file for squirmterm *)
RRef := OpenResFile(Name);
setvol(oldvol);
(* if the disk is locked, the res file won't
be
created *)
If !(RRef=-1) Then
NewRFile := 1;
};
If !(RRef = -1) Then {
S := NewHandle(Longint(Sizeof(Settings))); (* Make a new handle *)
S^^.Stops := Stops;
S^^.parity := parity; (* initialize settings *)
S^^.data := data;
S^^.baud := baud;
AddResource(S,PtrL(" SETT"+2)^,999,""); (* add the resource *)
WriteResource(S);
}
};
If S Then {
Stops := S^^.Stops;
Parity := S^^.parity;
Data := S^^.data;
Baud := S^^.baud;
ReleaseResource(S);
};
setstops(stops);
setparity(parity);
setdata(data);
setbaud(baud);
};
proc HaltSettings();
Var
S: SetHand;
{
(* update the resource values which contain settings *)
S := GetResource(PtrL(" SETT"+2)^,999);
If !S Then Return;
S^^.Stops := Stops;
S^^.parity := parity;
S^^.data := data;
S^^.baud := baud;
ChangedResource(S);
WriteResource(S);
If NewRFile Then
CloseResFile(RREf);
};
procedure sfsavebits();
var pl: ptrl;
pw: ptrw;
A0,A1,D0:longint;
x,y: integer;
{
sfbits := NewPtr(7454L);
if (sfbits) then {
getport(@sfmyport);
pl := sfbitmap;
pl^ := sfbits;
pw := sfbitmap+4;
pw^ := 46;
x := 100; y:=70;
GlobalToLocal(@y);
setrect(@sfbitmap[6],x-8,y-8,x+353,y+151);
copybits(@sfmyport[2],sfbitmap,@sfbitmap[6],@sfbitmap[6],0,0L);
};
};
procedure sfrestorbits();
var A0,A1,D0: longint;
{
if (sfbits<>0) then {
setport(sfmyport);
copybits(@sfbitmap,sfmyport+2,@sfbitmap[6],@sfbitmap[6],0,0L);
validrect(@sfbitmap[6]);
DisposPtr(sfbits);
};
};
procedure allfiles(nameptr: ptrL; vref: ptrw; good: ptrw);
var
pick: ptrw;
begin
Toolbox($A9EA,100,70," ",0L,-1," TEXT"+2L,0L,@myreply,2);
nameptr^ := @myreply+10;
pick := @myreply;
good^ := pick^ >> 8;
pick := pick+6;
vref^ := pick^;
end;
procedure hider();
var w: ptrL;
{
toolbox($A924,result w);
w := w + $90;
loop(w^<>0,w:=w^,w:=w+$90;w:=w^,w=0)
toolbox($A916, w);
};
procedure setbaud(abaud: integer);
{
checkEasy(500,baud,0);
baud := abaud;
zbaud := rateblock[baud];
if (baud=1) then zbaud:=zbaud+128;
checkEasy(500,baud,256);
setconfig(zbaud + zdata + zstops + zparity);
};
procedure setparity(apar: integer);
{
checkEasy(550,parity,0);
parity := apar;
Case Parity of
5: zparity:=0;
6: zparity:=12288;
7: zparity:=4096;
End;
checkEasy(550,parity,256);
setconfig(zbaud + zdata + zstops + zparity);
};
procedure setdata(adat: integer);
{
checkEasy(550,data,0);
data := adat;
Case Data of
9: zdata:=3072;
10: zdata:=1024;
11: zdata:=2048;
12: zdata:=0;
End;
checkEasy(550,data,256);
setconfig(zbaud + zdata + zstops + zparity);
};
procedure setstops(astop: integer);
{
checkEasy(550,stops,0);
stops := astop;
Case stops of
1: zstops:=-16384;
2: zstops:=-32768;
3: zstops:=16384;
End;
checkEasy(550,stops,256);
setconfig(zbaud + zdata + zstops + zparity);
};
procedure delete();
var param: block[94];
A0,A1,D0,pL: ptrL;
name,pb: ptrb;
vref,good: integer;
pw: ptrw;
{
loop(,,,) {
sfsavebits();
allfiles(@name,@vref,@good);
sfrestorbits();
if (good=0) then break;
pL := @param[12]; pL^ := 0;
pL := @param[18]; pL^ := name;
pw := @param[22]; pw^ := vref;
pb := @param[26]; pb^ := 0;
A0 := @param;
regcall(trap $A009,A0,A1,D0);
if (D0<>0) then writechar(7);
};
};
procedure sendfile();
var
name: ptrb;
vref,good,fref,eof,c,mods: integer;
{
sfsavebits();
getfile(@name,@vref,@good);
sfrestorbits();
if (good) then {
fopen(@fref,name,1,vref);
feof(fref,@eof);
loop(not eof,,,eof) {
loop(,,,c=13) {
termtask();
fgetc(fref,@c);
putchar(c);
feof(fref,@eof);
if (eof) then break;
};
seencr := 0;
loop(eof=0,,,) {
termtask();
if (seencr<>0) then break ;
checkkey(@c,@mods);
keyconv(@c,@mods);
if (c=127) then {
if ((mods and 512)=0) then eof := 255;
break;
};
};
c := -1;
};
fclose(fref);
};
};
procedure startrcv();
var name: ptrb;
vref,good: integer;
{
sfsavebits();
putfile(@name,@vref,@good);
sfrestorbits();
if (good) then {
mtoggle(600,5,@rcv);
fcreate(name," RCMP"+2," TEXT"+2,vref);
fopen(@rcfile,name,3,vref);
fseteof(rcfile,0L);
rcbptr := 0;
};
};
procedure flushrcbuf();
{
fwrite(rcfile,rcbuf,rcbptr);
rcbptr := 0;
};
procedure endrcv();
{
flushrcbuf();
fclose(rcfile);
mtoggle(600,5,@rcv);
};
procedure startprint();
Var t: longint;
{
LaserPrint := IsLaser();
If LaserPrint Then {
LPRInit(Courier,10);
SelectWindow(xxport);
}
Else {
prinit();
t := TickCount() + 30;
Loop(,,,TickCount()>t);
prlmargin(6);
};
mtoggle(600,9,@print);
};
procedure stopprint();
{
If LaserPrint Then
LPRHalt()
Else
prputchar(13);
mtoggle(600,9,@print);
};
procedure HardChar(x: integer);
{
If LaserPrint Then
LPRChar(x)
Else
PRPutChar(x);
};
procedure HardString(buf: ptrb);
{
If LaserPrint then
LPRString(buf)
Else
PRPutString(buf)
};
procedure filter(c: integer);
var err: integer;
{
if (c<>10) then {
rcbuf[rcbptr] := c;
rcbptr := rcbptr+1;
if (rcbptr>rcbsize) then {
flushrcbuf();
ferr(rcfile,@err);
if (err) then {
writechar(7);
writestring("File receive error");
endrcv()
};
};
};
};
procedure mtoggle(menu,item:integer; value: ptrw);
{
value^ := not value^;
checkEasy(menu,item,value^);
};
procedure doerase();
var p: integer[2]; {
getpen(p);
SetRect(myrect,p[1],p[0]-9,p[1]+6,p[0]+3);
EraseRect(myrect);
};
procedure docurse();
{penmode(10);pensize(1,2);
move(-1,1);line(7,0);move(-6,-1);
pensize(1,1); penmode(8)};
procedure getrect(rect: ptrL);
var port,prect: ptrL;
{
getport(@port); prect := port+16; rect^ := prect^;
prect := prect+4; rect := rect+4; rect^ := prect^;
};
procedure erasescr();
var prect: block[8];
{
getrect(prect);
eraserect(prect);
};
procedure scrollscr(h,v: integer);
var prect: block[8];
{
getrect(prect);
scrollrect(prect,h,v,utilrgn);
};
procedure rscroll(l,t,r,b,h,v: integer);
var rect: block[8];
p: integer[2];
x,y: integer;
{
getpen(p);
x:=p[1]; y:=p[0];
setrect(rect,x+l,y+t,x+r,y+b);
scrollrect(rect,h,v,utilrgn);
};
procedure insertc();
{
rscroll(0,-9,1000,3,charw,0);
};
procedure deletec();
{
rscroll(0,-9,1000,3,-charw,0);
};
procedure insertl();
{
rscroll(-1000,-9,1000,1000,0,lheight);
};
procedure deletel();
{
rscroll(-1000,-9,1000,1000,0,-lheight);
};
procedure clrtol();
{
rscroll(0,-9,5000,3,5000,0);
};
procedure clrtop();
{
clrtol();
rscroll(-1000,3,1000,1000,0,1000);
};
procedure getnext(x: ptrw);
var c,mods: integer;
{
loop(,,,x^<>-1) {
nodwellchar(x);
checkkey(@c,@mods);
if (c<>-1) then {
keyconv(@c,@mods);
putchar(c);
if (c=127) then break
};
};
if (x^<>-1) then x^:=x^%128;
};
procedure direct();
var x,y: integer;
{
getnext(@y);
if (y<>-1) then {
getnext(@x);
if (x<>-1) then {
x := x-32;
y := y-32;
x := (x+1)*charw;
y := (y+1)*lheight;
moveto(x,y);
};
};
};
procedure esc();
var x,c,mods: integer;
{
getnext(@x);
if (x<>-1) then
Case x of
12:{ erasescr(); moveto(charw,lheight) };
'U': scrollscr(0,-lheight);
'D': scrollscr(0,lheight);
'F': insertc();
'E': deletec();
'M': insertl();
'l': deletel();
'K': clrtol();
'k': clrtop();
'Y': direct();
End;
};
procedure adjustb();
{writechar(10)};
procedure control(c: integer);
{
Case c of
10: adjustb();
8: { writechar(c); doerase() };
13: {seencr := 255; writechar(c)};
11: move(0,-lheight);
15: move(-charw,0);
14: move(charw,0);
1: moveto(charw,lheight);
27: esc();
7: sysbeep(1);
OtherWise writechar(c);
End;
};
procedure termtask();
var x: Integer;
i,ctrl: byte;
buf: block[100];
rect: block[8];
h,v: integer;
p: integer[2];
begin
nodwellchar(@x);
if (x<>-1) then {
if (nocurse) then nocurse:=0 else docurse();
loop(,i:=0;ctrl:=0,,x=-1) {
x:=x%128;
if (rcv) then filter(x);
if (x>31) then { i:=i+1; buf[i] := x; }
else {ctrl := 255; break };
if (i>98) then break;
nodwellchar(@x);
};
if (i>0) then { buf[0]:=i;
getpen(p);
h := p[1]; v:=p[0];
setrect(rect,h,v-9,h+(i*charw)/1,v+3);
eraserect(rect);
DrawString(buf);
if (print) then
HardString(buf); }; (* drawstring *)
if (ctrl) then {
if (print) then
HardChar(x);
control(x);
};
docurse();
};
end;
procedure mactovi(px,py: ptrw);
{
px^ := (px^-charw)/charw;
py^ := (py^-lheight)/lheight;
};
procedure putdec(dec: integer);
var t: integer;
{
t := dec/10;
putchar(t+48);
t := dec-(t*10);
putchar(t+48);
};
procedure vimove(x,y: integer);
var
i: byte;
oldx,oldy: integer;
p: integer[2];
{
y := y+6;
mactovi(@x,@y);
getpen(p); oldx := p[1]; oldy := p[0];
mactovi(@oldx,@oldy);
if (oldy>y) then { putdec(oldy-y); putchar('-') };
if (oldy<y) then { putdec(y-oldy); putchar('j') };
putdec(x+1);
putchar('|');
};
procedure vichline();
{
putchar(27);
putchar('u');
putchar('C');
};
procedure vichword();
{
putchar('c');
putchar('w');
};
procedure _MOUSE(x,y: integer);
var time: longint;
{
time := TickCount();
if ((time-lastdbl)<dbltime) then { vichline(); lastdbl:=0 }
else if ((time-lastclick) < dbltime) then { vichword(); lastdbl:=time
}
else vimove(x,y);
lastclick:=time;
};
procedure _INIT();
{
getport(@xxport);
movewindow(xxport, 4, 40, 0B);
sizewindow(xxport, 504, 296, 0B);
hider();
initEasymenus();
stuffhex(rateblock,"00FCBD5E2E0A0401"); (* Baud rates for mac *)
addmenu(550,"Params");
additem(550,"2 Stops");
additem(550,"1.5 Stops");
additem(550,"1 Stop");
additem(550,"(-");
additem(550,"No Parity");
additem(550,"Even Parity");
additem(550,"Odd Parity");
additem(550,"(-");
additem(550,"8 Data");
additem(550,"7 Data");
additem(550,"6 Data");
additem(550,"5 Data");
addmenu(500,"Baud");
additem(500,"300");
additem(500,"600");
additem(500,"1200");
additem(500,"2400");
additem(500,"9600");
additem(500,"19.2k");
additem(500,"38.4k");
addmenu(600,"Options");
additem(600,"Send Break");
additem(600,"(-");
additem(600,"Send...");
additem(600,"(-");
additem(600,"Receive...");
additem(600,"(-");
additem(600,"Delete...");
additem(600,"(-");
additem(600,"Hard Copy");
rcv := 0;
print := 0;
dbltime := 20;lastclick:=0;lastdbl:=0;
InitSettings();
nocurse := 1;
lheight := 11;
charw := 6;
utilrgn := newrgn();
rcbsize := 1024;
moveto(charw,lheight);
end;
procedure _MENU(menuid,menuitem: integer);
begin
Case MenuId of
550: (* params menu *)
Begin
if (menuitem<4) then setstops(menuitem) else
if (menuitem<8) then setparity(menuitem) else
setdata(menuitem)
End;
600: (* Options Menu *)
Case MenuItem of
1: serbreak();
3: if !rcv then sendfile();
5: if rcv then endrcv() else startrcv();
7: delete();
9: if (print) then stopprint() else startprint();
end;
500: if (menuitem<>baud) then setbaud(menuitem);
End;
end;
procedure _KEY(c, mods : Integer);
var hit: integer;
{
obscurecursor();
hit := -1;
if (c='`') then { c := 27; mods:= 0 } else
if (c='Y') then { c := '`'; mods:=0 };
keyconv(@c,@mods);
if (c=19) then
loop(,,,hit<>-1) checkkey(@hit,@mods) (* fake ctrl-s *)
else
putchar(c);
if (c=127) then serflush();
};
procedure _HALT();
{
haltEasymenus();
disposergn(utilrgn);
haltSettings();
};
procedure _MAIN();
{ termtask() };