|
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: 22272 (0x5700)
Types: TextFile
Names: »ltctxt «
└─⟦9ccaf6601⟧ Bits:30008165 Bånd med SW8000 kildetekst/release værktøjer
└─⟦39138f30b⟧
└─⟦this⟧ »ltctxt «
begin
<********************************************************************>
<* Utility LISTTASCAT til udskrift af tas katalog indgange. *>
<* *>
<* Kald: <out-file> = listtascat <out-spec.> *>
<* *>
<* user.<name> *>
<* terminal.<name> *>
<* <out-spec.> ::= type.<number> *>
<* size *>
<* all *>
<* *>
<* Compiler call: listtascat=algol ltctxt connect.no *>
<********************************************************************>
<**************************************************************>
<* Revision history *>
<* *>
<* 87.02.01 listtascat release 1.0 *>
<* 88.01.07 MODE parameter added release 1.1 *>
<* 89.02.21 NOLOGIN parameter added, release 1.2 *>
<**************************************************************>
<* 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 *>
boolean file_out; <* True= connect to file *>
boolean no_found; <* Entry ikke fundet *>
integer array out_stack(1:4); <* out zone stack *>
integer array prog_name(1:4); <* Program navn *>
integer array conv(0:255); <* Tegn konverterings tabel *>
integer param; <* fp parameter tæller *>
integer user_size; <* Antal seg i user cat *>
integer term_size; <* Antal seg i term cat *>
integer type_size; <* Antal seg i type cat *>
integer user_hw; <* Antal hw i user entry *>
integer term_hw; <* Antal hw i term entry *>
integer type_hw; <* Antal hw i type entry *>
integer array field iaf; <* Work *>
real array field raf; <* Work *>
boolean array field baf; <* 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(2);
if monitor(18,buf,1,ia)<>1 then
error(5);
if ia(1)<>0 then
error(5);
for i:=1,2,3,4 do
user_id(i):=buf.iaf(i);
password:=buf.laf(3);
end;
procedure error(err_nr);
<*-----------------------------------------------*>
<* Udskriv fejlmeddelelse på cur. output og stop *>
<*-----------------------------------------------*>
integer err_nr;
begin
close_output;
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 (
<:connect output:>,<:claims:>,
<:no system:>,<:no privilege:>,
<:not allowed:>,<:parameter:>,
<:not found:>));
write(out,<:<10>:>);
goto stop;
end;
procedure set_output;
<*-----------------------------------------------*>
<* Set output zonen til enten cur. out eller fil *>
<*-----------------------------------------------*>
begin
integer seperator,result;
real array file_name(1:2);
seperator:=system(4,1,prog_name.raf);
if seperator shift (-12) = 6 then
begin
system(4,0,file_name);
fp_proc(29)stack_zone:(0,out,out_stack);
result:=2;
fp_proc(28)connect_output:(result,out,file_name);
if result=0 then
file_out:=true
else
error(1);
end
else
begin
system(4,0,prog_name.raf);
file_out:=false;
end;
end;
procedure close_output;
<*----------------------------------*>
<* Luk output zonen og unstack evt. *>
<*----------------------------------*>
begin
integer array ia(1:20);
integer size;
if file_out then
begin
fp_proc(34)close_up:(0,out,'em');
fp_proc(79)terminate_zone:(0,out,0);
getzone6(out,ia);
size:=ia(9);
monitor(42,out,0,ia);
ia(1):=size;
ia(6):=systime(7,0,0.0);
monitor(44,out,0,ia);
fp_proc(30)unstack_zone:(0,out,out_stack);
end;
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 get_cat_seg(cat_type,seg_nr,status,segments);
<*--------------------------------------------------------------*>
<* Send get catalog segment message til tas *>
<* Message sendes via zonen buf *>
<* Læst segment står i buf. *>
<* *>
<* cat_type (call) : 1=user, 2=terminal, 3=type *>
<* seg_nr (call) : Det segment der skal læses *>
<* status (ret) : Status bit ved retur (ingen sat = OK) *>
<* segments (ret) : Antal segmenter i angivet katalog *>
<*--------------------------------------------------------------*>
integer cat_type,seg_nr,status,segments;
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):=(3 shift 12);
share(5):=zone_ia(19)+1;
share(6):=share(5)+510;
share(7):=seg_nr;
share(8):=cat_type;
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);
status:=share(1);
segments:=share(4);
if not (false add (status shift (-23))) then
send:=true;
end;
end;
procedure write_field_name(key);
<*--------------------------------------*>
<* Udskriv navnet på feltet på ny linie *>
<*--------------------------------------*>
integer key;
begin
write(out,<:<10>:>);
write(out,true,12,case key of (
<:user:>,<:password:>,<:cpassword:>,<:monday:>,<:tuesday:>,
<:wednesday:>,<:thursday:>,<:friday:>,<:saturday:>,<:sunday:>,
<:sessions:>,<:privilege:>,<:mclname:>,<:base:>,<:groups:>,
<:mcltext:>,<:block:>,<:terminal:>,<:termtype:>,<:termgroup:>,
<:block:>,<:type:>,<:screentype:>,<:column:>,<:lines:>,
<:bypass:>,<:sbup:>,<:sbdown:>,<:sbleft:>,<:sbright:>,
<:sbhome:>,<:sbdelete:>,<:ceod:>,<:ceol:>,
<:home:>,<:left:>,<:right:>,<:up:>,<:down:>,<:mode:>,
<:nologin:>,<:invon:>,<:invoff:>,<:hlon:>,<:hloff:>,
<:delete:>,<:insert:>,<:cursor:>,<:init:>,<:freetext:>));
end;
procedure write_field(key,field_value,field_type);
<*------------------------------------------------------------------*>
<* Udskriv en linie indholden keyword og parrametre *>
<* *>
<* key (call) : Feltets key *>
<* field_value (call) : Peger til første hw i buf hvor værdier står *>
<* field_type (call) : Typen af værdien i feltet *>
<*------------------------------------------------------------------*>
integer key,field_value,field_type;
begin
long array field llaf;
integer array field liaf;
long field lf;
integer field inf;
boolean array field baf;
integer pos,i,j,ch;
case field_type of
begin
begin <* 1 *>
write_field_name(key);
llaf:=field_value-1;
write(out,buf.llaf);
end;
begin <* 2 *>
llaf:=liaf:=field_value-1;
if (buf.liaf(1) shift (-4))<>0 then
begin
write_field_name(key);
buf.liaf(11):=0;
write(out,buf.llaf);
end;
end;
begin <* 3 *>
baf:=field_value;
if buf.baf(0) then
write_field_name(key);
end;
begin <* 4 *>
lf:=field_value+3;
if buf.lf<>0 then
begin
write_field_name(key);
write(out,<<dd>,buf.lf);
end;
end;
begin <* 5 *>
write_field_name(key);
inf:=field_value+1;
write(out,<<dd>,buf.inf);
end;
begin <* 6 *>
baf:=field_value;
i:=buf.baf(0) extract 12;
if i<>0 then
begin
write_field_name(key);
write(out,<<dd>,i);
end;
end;
begin <* 7 *>
llaf:=field_value-1;
if get_char(buf.llaf,1,conv,ch) extract 12<>0 then
begin
write_field_name(key);
pos:=1;
repeat
get_char(buf.llaf,pos,conv,ch);
if ch<>0 then
write(out,<<zdd >,ch);
until pos>6 or ch=0;
end;
end;
begin <* 8 *>
llaf:=field_value-1;
if get_char(buf.llaf,1,conv,ch) extract 12<>0 then
begin
write_field_name(key);
pos:=1;
repeat
get_char(buf.llaf,pos,conv,ch);
if ch<>0 then
write(out,<<zdd >,ch);
until pos>9 or ch=0;
end;
end;
begin <* 9 *>
llaf:=field_value-1;
if get_char(buf.llaf,1,conv,ch) extract 12<>0 then
begin
write_field_name(key);
pos:=1;
repeat
get_char(buf.llaf,pos,conv,ch);
if ch<>0 then
write(out,<<zdd >,ch);
until pos>75 or ch=0;
end;
end;
begin <* 10 *>
baf:=field_value;
i:=buf.baf(0) extract 12;
if i<>0 then
begin
write_field_name(key);
for pos:=11 step (-1) until 0 do
begin
if false add (i shift (-pos)) then
write(out,<<dd >,11-pos);
end;
end;
end;
begin <* 11 *>
write_field_name(key);
for j:=1 step 2 until 7 do
begin
inf:=field_value+j;
i:=buf.inf;
for pos:=23 step (-1) until 0 do
begin
if false add (i shift (-pos)) then
write(out,<<dd >,23-pos+((j-1)*12));
end;
end;
end;
begin <* 12 *>
llaf:=field_value+1;
if buf.llaf(0) extract 12<>0 then
begin
write_field_name(key);
put_char(buf.llaf,(buf.llaf(0) extract 12)+1,0);
write(out,buf.llaf);
end;
end;
begin <* 13 *>
write_field_name(key);
inf:=field_value+1;
write(out,<<d>,buf.inf);
inf:=field_value+3;
write(out,<: :>,<<d>,buf.inf);
end;
begin <* 14 *>
baf:=field_value;
i:=buf.baf(0) extract 12;
if (i extract 2)<>0 then
begin
write_field_name(key);
write(out,<<dd >,i shift (-7),i shift (-2) extract 5);
end;
end;
begin <* 15 *>
baf:=field_value;
i:=(buf.baf(0) extract 12) shift (-1);
if i<>0 then
begin
write_field_name(key);
write(out,<<dd>,i);
end;
end;
end;
end;
procedure list_user;
<*--------------------------------------*>
<* Udskriv indholdet af 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(132,1,0,result);
if result=0 then
begin
for i:=1 step 1 until 17 do
write_field( case i of (
1,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,50),
case i of (
13,21,25,26,27,28,29,30,31,33,34,35,43,47,55,32,111),
case i of (
1,4,14,14,14,14,14,14,14,6,10,1,13,11,12,6,2));
end
else
if result<>2 then
begin
if result=4 then
error(4)
else
if result=13 then
error(5)
else
error(8);
end
else
begin
no_found:=true;
write(out,<:<10>; user.:>,u_id.laf,<: entry not found:>);
end;
write(out,<:<10>:>);
end
else
error(6);
end;
procedure list_term;
<*------------------------------------------*>
<* Udskriv indholdet af 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(46,2,0,result);
if result=0 then
begin
for i:=1 step 1 until 6 do
write_field( case i of (18,19,20,26,41,21,50),
case i of (13,21,24,23,23,22,25),
case i of (1,6,6,3,15,6,2));
end
else
if result<>2 then
begin
if result=4 then
error(4)
else
if result=13 then
error(5)
else
error(9);
end
else
begin
no_found:=true;
write(out,<:<10>; terminal.:>,buf.llaf,<: entry not found:>);
end;
write(out,<:<10>:>);
end
else
error(6);
end;
procedure list_type;
<*--------------------------------------*>
<* Udskriv indholdet af 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(140,3,0,result);
if result=0 then
begin
for i:=1 step 1 until 27 do
write_field( case i of (
22,23,40,24,25,27,28,29,30,31,32,33,34,35,36,37,38,39,
42,43,44,45,46,47,48,49,50),
case i of (
13,15,16,17,18,19,20,21,22,23,24,25,29,67,65,66,63,64,
33,37,41,45,49,53,57,69,119),
case i of (
5,10,6,6,6,6,6,6,6,6,6,7,7,6,6,6,6,6,7,7,7,7,7,7,8,
9,2));
end
else
if result<>2 then
begin
if result=4 then
error(4)
else
if result=13 then
error(5)
else
error(5);
end
else
begin
no_found:=true;
write(out,<:<10>; type.:>,<<d>,entier type(1),<: entry not found:>);
end;
write(out,<:<10>:>);
end
else
error(6);
end;
procedure list_size;
<*-------------------------------------------------*>
<* Udskriv antallet af indgange i de tre kataloger *>
<*-------------------------------------------------*>
begin
integer user_ent,term_ent,type_ent,status;
get_cat_seg(1,0,status,user_size);
if status<>0 then
begin
if false add (status shift (-11)) then
error(4)
else
if false add (status shift (-10)) then
error(5)
else
error(11);
end;
user_hw:=buf.iaf(3);
user_ent:=(user_size-1)*(512//user_hw);
get_cat_seg(2,0,status,term_size);
if status<>0 then
begin
if false add (status shift (-11)) then
error(4)
else
if false add (status shift (-10)) then
error(5)
else
error(12);
end;
term_hw:=buf.iaf(3);
term_ent:=(term_size-1)*(512//term_hw);
get_cat_seg(3,0,status,type_size);
if status<>0 then
begin
if false add (status shift (-11)) then
error(4)
else
if false add (status shift (-10)) then
error(5)
else
error(13);
end;
type_hw:=buf.iaf(3);
type_ent:=(type_size-1)*(512//type_hw);
write(out,<:; Catalog generated at: :>);
outdate(out,entier systime(6,buf.iaf(4),0.0));
write(out,<:<10>size :>,<<d>,
user_ent,<:,:>,term_ent,<:,:>,type_ent);
write(out,<: ; Max. entries (User,Terminal,Terminaltype)<10>:>);
end;
procedure list_all;
<*-----------------------------------------*>
<* Udskriv alle indgange i de 3 kataloger *>
<*-----------------------------------------*>
begin
integer array field base;
integer seg_nr,i;
list_size;
for seg_nr:=1 step 1 until user_size-1 do
begin
get_cat_seg(1,seg_nr,0,0);
for base:=4 step user_hw until ((512//user_hw)-1)*user_hw+4 do
begin
if buf.base(0)<>0 then
begin
for i:=1 step 1 until 17 do
write_field( case i of (
1,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,50),
base-12+(case i of (
13,21,25,26,27,28,29,30,31,33,34,35,43,47,55,32,111)),
case i of (
1,4,14,14,14,14,14,14,14,6,10,1,13,11,12,6,2));
write(out,<:<10>:>);
end;
end;
end;
for seg_nr:=1 step 1 until term_size-1 do
begin
get_cat_seg(2,seg_nr,0,0);
for base:=4 step term_hw until ((512//term_hw)-1)*term_hw+4 do
begin
if buf.base(0)<>0 then
begin
for i:=1 step 1 until 6 do
write_field( case i of (18,19,20,26,41,21,50),
base-12+(case i of (13,21,24,23,23,22,25)),
case i of (1,6,6,3,15,6,2));
write(out,<:<10>:>);
end;
end;
end;
for seg_nr:=1 step 1 until type_size-1 do
begin
get_cat_seg(3,seg_nr,0,0);
for base:=0 step type_hw until ((512//type_hw)-1)*type_hw do
begin
if buf.base(1)<>0 then
begin
for i:=1 step 1 until 27 do
write_field( case i of (
22,23,40,24,25,27,28,29,30,31,32,33,34,35,36,37,38,39,
42,43,44,45,46,47,48,49,50),
base-12+(case i of (
13,15,16,17,18,19,20,21,22,23,24,25,29,67,65,66,63,64,
33,37,41,45,49,53,57,69,119)),
case i of (
5,10,6,6,6,6,6,6,6,6,6,7,7,6,6,6,6,6,7,7,7,7,7,7,8,
9,2));
write(out,<:<10>:>);
end;
end;
end;
end;
procedure list;
<*-----------------------------------------------*>
<* Bestem hvilken type udskrift der skal udføres *>
<*-----------------------------------------------*>
begin
real array name(1:2);
param:=if file_out then
2
else
1;
while system(4,param,name)<>0 do
begin
param:=param+1;
if name.laf(1)= long <:user:> then
list_user
else
if name.laf(1)= long <:termi:> add 'n' then
list_term
else
if name.laf(1)= long <:type:> then
list_type
else
if name.laf(1)= long <:size:> then
list_size
else
if name.laf(1)= long <:all:> then
list_all
else
error(6);
end;
end;
<* Hoved program *>
trap(alarm);
trapmode:=1 shift 10;
raf:=laf:=iaf:=baf:=0;
no_found:=false;
for i:=0 step 1 until 255 do
conv(i):=i;
set_output;
get_userid;
set_buf_zone;
list;
if file_out and no_found then
error(7);
alarm:
close_output;
stop:
end;
▶EOF◀