|
DataMuseum.dkPresents historical artifacts from the history of: RC4000/8000/9000 |
This is an automatic "excavation" of a thematic subset of
See our Wiki for more about RC4000/8000/9000 Excavated with: AutoArchaeologist - Free & Open Source Software. |
top - metrics - download
Length: 7680 (0x1e00)
Types: TextFile
Names: »dtctxt «
└─⟦9ccaf6601⟧ Bits:30008165 Bånd med SW8000 kildetekst/release værktøjer
└─⟦39138f30b⟧
└─⟦this⟧ »dtctxt «
begin
<********************************************************************>
<* Utility DELTASCAT til sletning af tas katalog indgange. *>
<* *>
<* Kald: deltascat <del-spec.> *>
<* *>
<* user.<name> *>
<* <del-spec.> ::= terminal.<name> *>
<* type.<number> *>
<* *>
<* Compiler call: deltascat=algol dtctxt connect.no *>
<********************************************************************>
<**************************************************************>
<* Revision history *>
<* *>
<* 86.12.01 deltascat release 1.0 *>
<**************************************************************>
<* Globale variable *>
zone buf(128,1,std_error); <* Zone til message m.m. *>
integer array user_id(1:4); <* Bruger id fra terminal *>
long password; <* Password fra terminal *>
integer array prog_name(1:4); <* Program navn *>
integer array conv(0:255); <* Tegn konverterings tabel *>
integer param; <* fp parameter tæller *>
integer array field iaf; <* Work *>
real array field raf; <* Work *>
long array field laf; <* Work *>
integer i; <* Work *>
<* Globale procedure *>
procedure get_userid;
<*-------------------------------------------------------------------*>
<* Set user id og password i de globale variable user_id og password *>
<* Id og password hentes fra terminalen tilknyttet prim. output *>
<*-------------------------------------------------------------------*>
begin
long array term_name(1:2);
integer i;
integer array ia(1:20);
system(7,0,term_name);
open(buf,0,term_name,0);
close(buf,false);
getzone6(buf,ia);
i:=ia(19);
getshare6(buf,ia,1);
ia(4):=131 shift 12;
ia(5):=i+1;
ia(6):=i+11;
ia(7):=0;
setshare6(buf,ia,1);
if monitor(16,buf,1,ia)=0 then
error(7);
if monitor(18,buf,1,ia)<>1 then
error(3);
if ia(1)<>0 then
error(3);
for i:=1,2,3,4 do
user_id(i):=buf.iaf(i);
password:=buf.laf(3);
end;
procedure error(err_nr);
<*-----------------------------------------------*>
<* Udskriv fejlmeddelelse og stop hvis fatal *>
<*-----------------------------------------------*>
integer err_nr;
begin
if err_nr>2 then
write(out,<:***:>,prog_name.laf,<: :>);
if err_nr<1 or err_nr>7 then
write(out,<:internal :>,err_nr)
else
write(out,case err_nr of (
<:in use:>,<:not found:>,
<:not allowed:>,<:no privilege:>,
<:no system:>,<:parameter:>,
<:claims:>));
write(out,<:<10>:>);
if err_nr>2 then
goto stop;
end;
procedure set_buf_zone;
<*-------------------------------------------*>
<* Sæt zonen buf klar til message til tas *>
<*-------------------------------------------*>
begin
open(buf,0,<:tas:>,0);
close(buf,false);
end;
procedure send_modify_mess(size,mode,func,result);
<*--------------------------------------------------------------*>
<* Send modify message til tas. Repeter hvis process stoppes *>
<* Message sendes via zonen buf *>
<* *>
<* size (call) : Antal hw der skal sendes/modtages i buf *>
<* mode (call) : 1=user, 2=terminal, 3=type *>
<* func (call) : 0=get, 1=modify, 2=set new, 3=delete *>
<* result (ret) : Resultat fra message, 0=OK *>
<*--------------------------------------------------------------*>
integer size,mode,func,result;
begin
integer array share(1:12),zone_ia(1:20);
boolean send;
integer i;
send:=false;
while not send do
begin
getshare6(buf,share,1);
getzone6(buf,zone_ia);
share(1):=0;
share(4):=(11 shift 12)+mode;
share(5):=zone_ia(19)+1;
share(6):=share(5)+size-2;
share(7):=func;
setshare6(buf,share,1);
for i:=1 step 1 until 4 do
buf.iaf(i):=user_id(i);
buf.iaf(5):=password shift (-24);
buf.iaf(6):=password extract 24;
if monitor(16,buf,1,share)=0 then
error(2);
if monitor(18,buf,1,share)<>1 then
error(3);
result:=share(1);
if result<>8 then
send:=true;
end;
end;
procedure del_user;
<*----------------------*>
<* Slet en user indgang *>
<*----------------------*>
begin
integer array u_id(1:4);
integer sep,i,result;
sep:=system(4,param,u_id.raf);
if sep=(8 shift 12 + 10) then
begin
param:=param+1;
for i:=1 step 1 until 4 do
buf.iaf(6+i):=u_id(i);
send_modify_mess(20,1,3,result);
write(out,<:user.:>,u_id.laf,<: :>);
if result<>0 then
begin
if result=13 then
error(3)
else
error(result);
end
else
write(out,<:deleted<10>:>);
end
else
error(6);
end;
procedure del_term;
<*--------------------------*>
<* Slet en terminal indgang *>
<*--------------------------*>
begin
long array t_id(1:2);
integer sep,i,j,ch,result;
long array field llaf;
llaf:=12;
sep:=system(4,param,t_id.raf);
if sep=(8 shift 12 + 10) then
begin
param:=param+1;
j:=i:=1;
get_char(t_id,i,conv,ch);
if ch='t' then
get_char(t_id,i,conv,ch);
buf.llaf(2):=0;
while i<13 do
begin
put_char(buf.llaf,j,conv,ch);
get_char(t_id,i,conv,ch);
end;
send_modify_mess(20,2,3,result);
write(out,<:terminal.:>,buf.llaf,<: :>);
if result<>0 then
begin
if result=13 then
error(3)
else
error(result);
end
else
write(out,<:deleted<10>:>);
end
else
error(6);
end;
procedure del_type;
<*----------------------*>
<* Slet en type indgang *>
<*----------------------*>
begin
real array type(1:2);
integer sep,i,result;
sep:=system(4,param,type);
if sep=(8 shift 12 + 4) then
begin
param:=param+1;
buf.iaf(7):=type(1);
send_modify_mess(14,3,3,result);
write(out,<:type.:>,<<d>,buf.iaf(7),<: :>);
if result<>0 then
begin
if result=13 then
error(3)
else
error(result);
end
else
write(out,<:deleted<10>:>);
end
else
error(6);
end;
procedure delete;
<*-----------------------------------------------*>
<* Bestem hvilken indgange der skal slettes *>
<*-----------------------------------------------*>
begin
real array name(1:2);
while system(4,param,name)<>0 do
begin
param:=param+1;
if name.laf(1)= long <:user:> then
del_user
else
if name.laf(1)= long <:termi:> add 'n' then
del_term
else
if name.laf(1)= long <:type:> then
del_type
else
error(6);
end;
end;
<* Hoved program *>
trapmode:=1 shift 10;
raf:=laf:=iaf:=0;
for i:=0 step 1 until 255 do
conv(i):=i;
if system(4,1,prog_name.raf)=(6 shift 12 + 10) then
param:=2
else
begin
system(4,0,prog_name.raf);
param:=1;
end;
get_userid;
set_buf_zone;
delete;
stop:
end;
▶EOF◀