|
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: 30720 (0x7800)
Types: TextFile
Names: »stctxt «
└─⟦9ccaf6601⟧ Bits:30008165 Bånd med SW8000 kildetekst/release værktøjer
└─⟦39138f30b⟧
└─⟦this⟧ »stctxt «
<********************************************************************>
<* Utility SETTASCAT til indsættelse og opdatering af indgange *>
<* *>
<* Kald: settascat <in-spec.> *>
<* *>
<* <in-spec.> ::= current input or file *>
<* *>
<* Compiler call: settascat=algol stctxt connect.yes *>
<* *>
<********************************************************************>
<**************************************************************>
<* Revision history *>
<* *>
<* 86.12.01 settascat release 1.0 *>
<* 88.01.07 MODE parameter added, screentype only 0 - 11 *>
<* release 1.1 *>
<* 89.02.21 NOLOGIN parameter added, release 1.2 *>
<**************************************************************>
begin
<* 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 line_nr; <* Input linie nummer *>
integer array mcl_bases(1:2); <* System mcl baser *>
integer num_keys; <* Antal keywords *>
long array keywords(0:60); <* Keywords array *>
integer array field iaf; <* Work *>
real array field raf; <* Work *>
boolean array field baf; <* Work *>
long array field laf; <* Work *>
integer i; <* Work *>
<* Procedure til afhjælpelse af fejl i externe procedure *>
integer procedure put_ch(dest,pos,char,rep);
long array dest;
integer pos,char,rep;
begin
trap(local);
put_ch:=putchar(dest,pos,char,rep);
if false then
local: put_ch:=-1;
end;
integer procedure put_txt(dest,pos,text,length);
long array dest,text;
integer pos,length;
begin
trap(local);
put_txt:=puttext(dest,pos,text,length);
if false then
local: put_txt:=-1;
end;
<* Globale procedure *>
procedure init_keywords;
<*-------------------------------------------*>
<* initialiser keywords *>
<*-------------------------------------------*>
begin
integer i;
num_keys:=51;
for i:=1 step 1 until num_keys do
begin
keywords(i):=0;
keywords(i):= long (case i of
<* 1 *> (<:end:>,<:size:>,<:user:>,<:passw:>,<:cpass:>,
<* 6 *> <:monda:>,<:tuesd:>,<:wedne:>,<:thurs:>,<:frida:>,
<* 11 *> <:satur:>,<:sunda:>,<:block:>,<:sessi:>,<:privi:>,
<* 16 *> <:mclna:>,<:base:>,<:group:>,<:mclte:>,<:freet:>,
<* 21 *> <:termi:>,<:termt:>,<:termg:>,<:bypas:>,<:type:>,
<* 26 *> <:scree:>,<:colum:>,<:lines:>,<:sbup:>,<:sbdow:>,
<* 31 *> <:sblef:>,<:sbrig:>,<:sbhom:>,<:sbdel:>,<:ceod:>,
<* 36 *> <:ceol:>,<:invon:>,<:invof:>,<:hlon:>,<:hloff:>,
<* 41 *> <:delet:>,<:inser:>,<:curso:>,<:up:>,<:down:>,
<* 46 *> <:left:>,<:right:>,<:home:>,<:mode:>,<:init:>,
<* 51 *> <:nolog:>));
end;
end;
integer procedure find_keyword_value(keyword);
<*----------------------------------------------------------------*>
<* Find 'token' værdien for det angivne keyword *>
<* *>
<* keyword (call) : Long indeholdende op til 5 tegn af keyword *>
<* Return : Værdien for det angivne keyword eller *>
<* 0 hvis keyword er ukendt *>
<*----------------------------------------------------------------*>
long keyword;
begin
integer i;
i:=num_keys+1;
keyword:=(keyword shift (-8)) shift 8;
for i:=i-1 while not (keyword=keywords(i)) and (i<>0) do; <* nothing *>
find_keyword_value:=i;
if i=0 and keyword<>0 then
write_mess(8,false);
end;
procedure next_line;
<*-------------------------------------------------------*>
<* Læs til starten af næste linie i input *>
<* Linier der starter med ; eller er blanke overspringes *>
<* Linie tæller optælles med 1 for hver linie *>
<* *>
<*-------------------------------------------------------*>
begin
integer i;
repeatchar(in);
readchar(in,i);
while (i<>'nl') and (i<>'em') do
readchar(in,i);
line_nr:=line_nr+1;
readchar(in,i);
if i<>'em' then
begin
while i=' ' do
readchar(in,i);
if i='nl' or i='em' or i=';' then
begin
next_line;
readchar(in,i);
end;
end;
repeatchar(in);
end;
integer procedure read_start_key;
<*-------------------------------------------------------------------*>
<* Find værdien af nøgleordet i starten af tekst linien i input *>
<* *>
<* Return : -1 = Sidste linie i fil er læst *>
<* 0 = Nøgleord er ikke fundet *>
<* >0 = Nøgleordets værdi *>
<*-------------------------------------------------------------------*>
begin
long array key(1:5);
integer i;
readchar(in,i);
if i<>'em' then
begin
while i=' ' do
readchar(in,i);
if i='nl' or i='em' or i=';' then
begin
next_line;
readchar(in,i);
end;
end;
repeatchar(in);
read_start_key:=if readstring(in,key,1)>0 then
find_keyword_value(key(1))
else
-1;
repeatchar(in);
end;
integer procedure read_text(text,max);
<*---------------------------------------------------------------------*>
<* Læs tekst fra input til text, til slutning af linie eller til *>
<* maximalt antal tegn læst. Indledende blanktegn overspringes. *>
<* *>
<* text (ret) : Den læste tekst *>
<* max (call) : Det maximale antal tegn der læses *>
<* Return : Antal tegn læst til text *>
<* *>
<*---------------------------------------------------------------------*>
integer max;
long array text;
begin
integer ch,pos;
boolean first;
pos:=1;
first:=true;
text(1):=0;
repeatchar(in);
readchar(in,ch);
if (ch<>'nl') and (ch<>'em') then
begin
readchar(in,ch);
while ch<>'nl' and ch<>'em' and pos<=max do
begin
if first and (ch<>' ') then
first:=false;
if -,first then
put_ch(text,pos,ch,1);
readchar(in,ch);
end;
end;
read_text:=pos-1;
if pos<=max then
put_ch(text,pos,0,1);
repeatchar(in);
end;
boolean procedure read_nr(nr);
<*-----------------------------------------------------------------*>
<* Læs et heltal fra input. Er der ikke flere tal på linien *>
<* returneres -1 ellers det læste tal. Er der angivet ulovligt *>
<* tal (eller andet end tal) sættes read_nr til false *>
<* *>
<* nr (ret) : Læst tal eller -1 hvis ikke flere tal *>
<* Return : True = ok False = illegalt tal *>
<*-----------------------------------------------------------------*>
integer nr;
begin
integer ch,class;
read_nr:=true;
repeat
class:=readchar(in,ch);
until class<>7 or ch=';' ;
if ch=';' or class=8 then
nr:=-1
else
if class<2 or class>3 then
begin
nr:=-1;
read_nr:=false;
end
else
begin
repeatchar(in);
read(in,nr);
end;
repeatchar(in);
end;
boolean procedure read_name(name,ok);
<*---------------------------------------------------------------------*>
<* Læs et navn fra input til name. Resterende tegn nulstilles *>
<* Indledende blanktegn overspringes. Der stoppes ved kommentar *>
<* *>
<* name (ret) : Det læste navn i integer array name(1:4) *>
<* ok (ret) : True hvis navnet starter med bogstav *>
<*---------------------------------------------------------------------*>
integer array name;
boolean ok;
begin
integer ch,pos;
ok:=false;
for pos:=1,2,3,4 do
name(pos):=0;
pos:=1;
repeatchar(in);
readchar(in,ch);
while ch=' ' do
readchar(in,ch);
if ch>='a' and ch<='å' then
ok:=true;
while ((ch>='0'and ch<='9') or (ch>='a' and ch<='å')) and pos<=11 do
begin
put_ch(name.laf,pos,ch,1);
readchar(in,ch);
end;
repeatchar(in);
read_name:=not name(1)=0;
end;
procedure clear_high(i);
<*---------------------------*>
<* Nulstil 12 high bit i ord *>
<*---------------------------*>
integer i;
begin
i:=(i shift 12) shift (-12);
end;
procedure clear_low(i);
<*---------------------------*>
<* Nulstil 12 low bit i ord *>
<*---------------------------*>
integer i;
begin
i:=(i shift (-12)) shift 12;
end;
procedure set_entry;
<*------------------------------------------------------*>
<* Indsæt værdier læst fra input i indgange i kataloget *>
<*------------------------------------------------------*>
begin
integer key,result,i,first,last,type;
integer array id(1:4);
integer array field entry;
boolean exist,ok;
long array password(1:8);
line_nr:=1;
key:=read_start_key;
while key=0 or key=2 do
begin
if key=2 then
begin
write(out,<:Size field ignored<10>:>);
setposition(out,0,0);
end;
next_line;
key:=read_start_key;
end;
while (key<>1 <* end *>) and (key<>-1) do
begin
if key=3 then
begin <* user entry *>
if not read_name(id,ok) then
write_mess(12,false);
if not ok then
write_mess(12,false);
for i:=1,2,3,4 do
buf.iaf(i+6):=id(i);
send_modify_mess(132,1,0,result);
if result=0 or result=2 then
begin <* ok *>
entry:=10;
exist:=true;
write(out,<:User :>,id.laf,<: :>);
if result=2 then
begin <* ny bruger *>
<* init entry *>
exist:=false;
for i:=6 step 1 until 61 do
buf.entry(i):=0;
buf.entry(12):=1 shift 12; <* Max sessions *>
buf.entry(23):=2 shift 12; <* mcl def. text empty *>
buf.entry(19):=1 shift 23; <* term. group 0 *>
end;
next_line;
key:=read_start_key;
while (key>=4) and (key<=20) do
begin
<* indsæt i entry *>
if (key>=6) and (key<=12) then
begin <* læs first og last for login tid *>
if not(read_nr(first) and read_nr(last)) then
write_mess(11,false);
if first<0 or first>24 or last<0 or last>24 then
write_mess(11,false);
type:=if first=0 and last=24 then
3
else
if first=last then
0
else
if first<last then
1
else
2;
end;
begin
case key-3 of
begin
begin <* password *>
for i:=1 step 1 until 8 do
password(i):=0;
buf.entry(6):=0;
buf.entry(7):=0;
if read_text(password,48)>0 then
begin <* kod password *>
for last:=1 step 1 until 31 do
begin
key:=password.baf(last) extract 12;
for i:=last+1 step 1 until 32 do
password.baf(i):=false add
((password.baf(i) extract 12) + key);
end;
for i:=1 step 1 until 16 do
begin
buf.entry(6):=buf.entry(6)+
password.iaf(i);
buf.entry(7):=buf.entry(7)+
buf.entry(6);
end;
end;
end;
begin <* kodet password *>
read(in,password(1));
buf.entry(6):=password(1) shift (-24);
buf.entry(7):=password(1) extract 24;
end;
begin <* monday *>
clear_high(buf.entry(8));
buf.entry(8):=buf.entry(8)+
((first shift 7)+(last shift 2) + type) shift 12;
end;
begin <* tuesday *>
clear_low(buf.entry(8));
buf.entry(8):=buf.entry(8)+
((first shift 7)+(last shift 2) + type);
end;
begin <* wednesday *>
clear_high(buf.entry(9));
buf.entry(9):=buf.entry(9)+
((first shift 7)+(last shift 2) + type) shift 12;
end;
begin <* thursday *>
clear_low(buf.entry(9));
buf.entry(9):=buf.entry(9)+
((first shift 7)+(last shift 2) + type);
end;
begin <* friday *>
clear_high(buf.entry(10));
buf.entry(10):=buf.entry(10)+
((first shift 7)+(last shift 2) + type) shift 12;
end;
begin <* saturday *>
clear_low(buf.entry(10));
buf.entry(10):=buf.entry(10)+
((first shift 7)+(last shift 2) + type);
end;
begin <* sunday *>
clear_high(buf.entry(11));
buf.entry(11):=buf.entry(11)+
((first shift 7)+(last shift 2) + type) shift 12;
end;
begin <* block *>
if not read_nr(i) or i<0 then
write_mess(11,false);
clear_low(buf.entry(11));
buf.entry(11):=buf.entry(11)+i;
end;
begin <* sessions *>
clear_high(buf.entry(12));
if not read_nr(i) or i>9 or i<1 then
write_mess(11,false);
buf.entry(12):=buf.entry(12)+(i shift 12);
end;
begin <* privilegier *>
type:=0;
clear_low(buf.entry(12));
if not read_nr(i) then
write_mess(11,false);
while (i>=0) do
begin
if i>11 then
write_mess(11,false);
type:=type+(1 shift (11-i));
if not read_nr(i) then
write_mess(11,false);
end;
buf.entry(12):=buf.entry(12)+type;
end;
begin <* mcl name *>
if not read_name(id,ok) then
write_mess(12,false);
if not ok then
write_mess(12,false);
for i:=1,2,3,4 do
buf.entry(i+12):=id(i);
end;
begin <* mcl bases *>
if not(read_nr(first) and read_nr(last)) then
write_mess(11,false);
if first>last then
write_mess(11,false);
buf.entry(17):=first;
buf.entry(18):=last;
end;
begin <* groups *>
for i:=1 step 1 until 4 do
id(i):=0;
if not read_nr(i) then
write_mess(11,false);
while i>=0 do
begin
if i>95 then
write_mess(11,false);
first:=(i//24)+1;
last:=23-(i mod 24);
if -,(false add (id(first) shift (-last))) then
id(first):=id(first)+(1 shift last);
if not read_nr(i) then
write_mess(11,false);
end;
for i:=1 step 1 until 4 do
buf.entry(18+i):=id(i);
end;
begin <* mcl text *>
laf:=46;
i:=read_text(buf.entry.laf,80);
buf.entry(23):=
((((i+2)//3*2)+2) shift 12) + i;
laf:=0;
end;
begin <* free text *>
laf:=100;
read_text(buf.entry.laf,30);
laf:=0;
end;
end;
end;
next_line;
key:=read_start_key;
end;
if exist then
send_modify_mess(132,1,1,result)
else
send_modify_mess(132,1,2,result);
if result<>0 then
begin
if result=1 then
write_mess(1,true)
else
write_mess(result,false);
end
else
if exist then
write_mess(3,true)
else
write_mess(2,true);
end
else
write_mess(result,false);
end
else
if key=21 then
begin <* terminal entry *>
if not read_name(id,ok) then
write_mess(12,false);
for i:=1,2,3,4 do
buf.iaf(i+6):=id(i);
send_modify_mess(46,2,0,result);
if result=0 or result=2 then
begin
exist:=true;
entry:=10;
write(out,<:Terminal :>,id.laf,<: :>);
if result=2 then
begin
<* init entry *>
exist:=false;
for i:=7 step 1 until 18 do
buf.entry(i):=0;
buf.entry(6):=1 shift 12; <* terminal type *>
end;
next_line;
key:=read_start_key;
while (key>=22 and key<=24) or key=51 or key=13 or key=20 do
begin
<* indsæt i entry *>
if key=22 then
begin <* Terminal type *>
if not read_nr(i) or i<0 or i>2047 then
write_mess(11,false);
clear_high(buf.entry(6));
buf.entry(6):=buf.entry(6)+
i shift 12;
end;
if key=23 then
begin <* terminal group *>
if not read_nr(i) or i<0 or i>95 then
write_mess(11,false);
clear_low(buf.entry(7));
buf.entry(7):=buf.entry(7)+i;
end;
if key=20 then
begin <* free text *>
laf:=14;
read_text(buf.entry.laf,30);
laf:=0;
end;
if key=13 then
begin <* block *>
if not read_nr(i) or i<0 or i>4095 then
write_mess(11,false);
clear_low(buf.entry(6));
buf.entry(6):=buf.entry(6)+i;
end;
if key=24 then
begin <* bypass *>
buf.entry(7):=logand(buf.entry(7),(-4097));
if not read_nr(i) or i<>0 then
buf.entry(7):=buf.entry(7)+(1 shift 12);
end;
if key=51 then
begin <* nologin *>
buf.entry(7):=logand(buf.entry(7),8191);
if not read_nr(i) or i>99 or i<0 then
write_mess(11,false);
if i>0 then
buf.entry(7):=buf.entry(7)+(i shift 13);
end;
next_line;
key:=read_start_key;
end;
if exist then
send_modify_mess(46,2,1,result)
else
send_modify_mess(46,2,2,result);
if result<>0 then
begin
if result=1 then
write_mess(1,true)
else
write_mess(result,false);
end
else
if exist then
write_mess(3,true)
else
write_mess(2,true);
end
else
write_mess(result,false);
end
else
if key=25 then
begin <* type entry *>
if not read_nr(type) or type<1 or key>2047 then
write_mess(11,false);
buf.iaf(7):=type;
send_modify_mess(140,3,0,result);
if result=0 or result=2 then
begin
exist:=true;
entry:=12;
write(out,<:Type :>,<<dd>,type,<: :>);
if result=2 then
begin
<* init entry *>
exist:=false;
for i:=2 step 1 until 64 do
buf.entry(i):=0;
buf.entry(1):=type; <* terminal type *>
buf.entry(3):=(80 shift 12)+24;
end;
next_line;
key:=read_start_key;
while ((key>=26) and (key<=50)) or (key=20) do
begin
<* indsæt i entry *>
if key=26 then
begin <* screen type *>
type:=0;
if not read_nr(i) then
write_mess(11,false);
while (i>=0) do
begin
if i>11 then
write_mess(11,false);
type:=type+(1 shift (11-i));
if not read_nr(i) then
write_mess(11,false);
end;
buf.entry.baf(3):= false add (type extract 12);
end;
if key=49 then
begin <* mode *>
if not read_nr(i) then
write_mess(11,false);
if i<0 or i>9 then
write_mess(11,false);
buf.entry.baf(4):= false add (i extract 12);
end;
if (key>=27) and (key<=34) then
begin <* 'send by' værdier *>
boolean array field baf;
baf:=0;
if not read_nr(i) or i>255 or i<0 then
write_mess(11,false);
buf.entry.baf(key-22):=if i>0 then
false add i
else
false;
end;
if (key>=44) and (key<=48) then
begin <* et tegns værdier *>
boolean array field baf;
baf:=0;
if not read_nr(i) or i>255 or i<0 then
write_mess(11,false);
buf.entry.baf(key+7):=if i>0 then
false add i
else
false;
end;
if (key>=35) and (key<=42) then
begin <* 6 tegns sekevnser *>
if not read_nr(i) or i>255 or i<0 then
write_mess(11,false);
first:=1;
laf:=case (key-34) of
(12,16,20,24,28,32,36,40);
buf.entry.laf(1):=0;
while (i<>-1) and (first<=6) do
begin
put_ch(buf.entry.laf,first,i,1);
if first<=6 then
begin
if not read_nr(i) or i>255 or i<-1 then
write_mess(11,false);
end;
end;
laf:=0;
end;
if key=43 then
begin <* cursor sekvens *>
if not read_nr(i) or i>255 or i<0 then
write_mess(11,false);
first:=1;
laf:=44;
buf.entry.laf(1):=0;
while (i<>-1) and (first<=9) do
begin
put_ch(buf.entry.laf,first,i,1);
if first<=9 then
begin
if not read_nr(i) or i>255 or i<-1 then
write_mess(11,false);
end;
end;
laf:=0;
end;
if key=50 then
begin <* initialiserings sekvens *>
laf:=56;
put_ch(buf.entry.laf,1,0,75);
if not read_nr(i) or i>255 or i<0 then
write_mess(11,false);
first:=1;
while (i<>-1) and (first<=75) do
begin
put_ch(buf.entry.laf,first,i,1);
if first<=75 then
begin
if not read_nr(i) or i>255 or i<-1 then
write_mess(11,false);
end;
end;
laf:=0;
end;
if key=20 then
begin <* free text *>
laf:=106;
read_text(buf.entry.laf,30);
laf:=0;
end;
next_line;
key:=read_start_key;
end;
if exist then
send_modify_mess(140,3,1,result)
else
send_modify_mess(140,3,2,result);
if result<>0 then
begin
if result=1 then
write_mess(1,true)
else
write_mess(result,false);
end
else
if exist then
write_mess(3,true)
else
write_mess(2,true);
end
else
write_mess(result,false);
end
else
write_mess(8,false);
end;
end;
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
write_mess(5,false);
if monitor(18,buf,1,ia)<>1 then
write_mess(10,false);
if ia(1)<>0 then
write_mess(10,false);
for i:=1,2,3,4 do
user_id(i):=buf.iaf(i);
password:=buf.laf(3);
end;
procedure write_mess(nr,cont);
<*-------------------------------------------*>
<* Udskriv meddelelse på current output *>
<*-------------------------------------------*>
integer nr;
boolean cont;
begin
if not cont then
write(out,<: error<10>***:>,prog_name.laf,<: :>);
if nr=13 then
nr:=9;
if nr>13 then
write(out,<:internal :>,<<dd>,nr)
else
write(out,case nr of (
<:in use:>,<:inserted:>,<:updated:>,<:no privilege:>,
<:claims:>,<:catalog full:>,<:update conflict:>,
<:unknown field name:>,<:not allowed:>,<:no system:>,
<:illegal number:>,<:illegal name:>));
if nr=11 or nr=12 or nr=8 or nr=1 or nr=6 or nr=7 then
write(out,<: at line :>,<<dd>,line_nr);
write(out,<:<10>:>);
setposition(out,0,0);
if (not cont) or nr>13 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
write_mess(5,false);
if monitor(18,buf,1,share)<>1 then
write_mess(10,false);
result:=share(1);
if result<>8 then
send:=true;
end;
end;
<* Hoved program *>
trapmode:=1 shift 10;
raf:=laf:=iaf:=baf:=0;
line_nr:=0;
mcl_bases(1):=mcl_bases(2):=0;
for i:=0 step 1 until 255 do
conv(i):=i;
if system(4,1,prog_name.raf)<>(6 shift 12 + 10) then
system(4,0,prog_name.raf);
init_keywords;
get_userid;
set_buf_zone;
set_entry;
stop:
end;
▶EOF◀