|
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: 84480 (0x14a00)
Types: TextFile
Names: »utillist «
└─⟦9ccaf6601⟧ Bits:30008165 Bånd med SW8000 kildetekst/release værktøjer
└─⟦39138f30b⟧
└─⟦this⟧ »utillist «
*algol mvmcltxt connect.no list.yes
mvmcltxt d.861121.1142
1 begin
2 <********************************************************************>
3 <* Utility MOVEMCL til flytning af oversatte mcl programmer til *>
4 <* Tas mcl-database *>
5 <* *>
6 <* Kald: movemcl <move spec.> *>
7 <* *>
8 <* include.<name> *>
9 <* <move spec.> ::= get.<name> *>
10 <* lookup.<name> *>
11 <* lookup *>
12 <* *>
13 <* Henning Godske A/S Regnecentralen 861121 *>
14 <* Compiler call: movemcl=algol mvmcltxt connect.no *>
15 <********************************************************************>
16
16 <**************************************************************>
17 <* Revision history *>
18 <* *>
19 <* 86.12.01 movemcl release 1.0 *>
20 <**************************************************************>
21
21 <* Globale variable *>
22
22 zone buf(128,1,std_error); <* Zone til message m.m. *>
23 integer array user_id(1:4); <* Bruger id fra terminal *>
24 long password; <* Password fra terminal *>
25 integer array prog_name(1:4); <* Program navn *>
26 integer param; <* fp parameter tæller *>
27 integer array mcl_bases(1:2); <* Bases for mcl files *>
28 integer array user_bases(1:2); <* Egne bruger baser *>
29 integer array empty(1:4); <* Tomt navn *>
30 boolean eof; <* End Of File *>
31
31 integer array arr(1:8); <* Work *>
32 integer array field iaf; <* Work *>
33 real array field raf; <* Work *>
34 boolean array field baf; <* Work *>
35 long array field laf; <* Work *>
36 integer i; <* Work *>
37
37 <* Globale procedure *>
38
38 procedure get_userid;
39 <*-------------------------------------------------------------------*>
40 <* Set user id og password i de globale variable user_id og password *>
41 <* Id og password hentes fra terminalen tilknyttet prim. output *>
42 <*-------------------------------------------------------------------*>
43 begin
44 long array term_name(1:2);
45 integer i;
46 integer array ia(1:20);
47
47 system(7,0,term_name);
48 open(buf,0,term_name,0);
49 close(buf,false);
50 getzone6(buf,ia);
51 i:=ia(19);
52 getshare6(buf,ia,1);
53 ia(4):=131 shift 12;
54 ia(5):=i+1;
55 ia(6):=i+11;
56 ia(7):=0;
57 setshare6(buf,ia,1);
58 if monitor(16,buf,1,ia)=0 then
59 error(8,empty);
60 if monitor(18,buf,1,ia)<>1 then
61 error(11,empty);
62 if ia(1)<>0 then
63 error(13,empty);
64 for i:=1,2,3,4 do
65 user_id(i):=buf.iaf(i);
66 password:=buf.laf(3);
67 end;
68
68 procedure error(err_nr,name);
69 <*-----------------------------------------------*>
70 <* Udskriv fejlmeddelelse på cur. output og stop *>
71 <*-----------------------------------------------*>
72 integer err_nr;
73 integer array name;
74 begin
75 write(out,<:<10>***:>,prog_name.laf,<: :>,name.laf,<: :>);
76 if err_nr<1 or err_nr>13 then
77 write(out,<:internal :>,err_nr)
78 else
79 write(out,case err_nr of (
80 <:not found:>,<:error - not moved:>,
81 <:exist allready:>,<:protected:>,
82 <:in use:>,<:illegal name:>,
83 <:no privilegie:>,<:claims:>,
84 <:not a permanent file:>,<:parameter:>,
85 <:no system:>,<:internal 12:>,
86 <:not allowed:>));
87 write(out,<:<10>:>);
88 goto stop;
89 end;
90
90 procedure set_buf_zone;
91 <*-------------------------------------------*>
92 <* Sæt zonen buf klar til message til tas *>
93 <*-------------------------------------------*>
94 begin
95 open(buf,0,<:tas:>,0);
96 close(buf,false);
97 end;
98
98 procedure send_move_mess(mode,name,bases,result);
99 <*--------------------------------------------------------------*>
100 <* Send move message til Tas. Repeter hvis process stoppes *>
101 <* Message sendes via zonen buf *>
102 <* *>
103 <* mode (call) : 0= Base, 1=To, 2=From *>
104 <* name (call) : Navn på fil der skal flyttes *>
105 <* bases(call) : Bruger baser hvor fil skal til/fra *>
106 <* result (ret) : Resultat fra message, 0=OK *>
107 <*--------------------------------------------------------------*>
108 integer mode,result;
109 integer array name,bases;
110 begin
111 integer array share(1:12),zone_ia(1:20);
112 boolean send;
113 integer i;
114
114 send:=false;
115 while not send do
116 begin
117 getshare6(buf,share,1);
118 getzone6(buf,zone_ia);
119 share(1):=0;
120 share(4):=(15 shift 12)+mode;
121 share(5):=zone_ia(19)+1;
122 share(6):=share(5)+22;
123 setshare6(buf,share,1);
124 for i:=1 step 1 until 4 do
125 buf.iaf(i):=user_id(i);
126 buf.iaf(5):=password shift (-24);
127 buf.iaf(6):=password extract 24;
128 for i:=1,2,3,4 do
129 buf.iaf(6+i):=name(i);
130 buf.iaf(11):=bases(1);
131 buf.iaf(12):=bases(2);
132 if monitor(16,buf,1,share)=0 then
133 error(8,empty);
134 if monitor(18,buf,1,share)<>1 then
135 error(11,empty);
136 result:=share(1);
137 mcl_bases(1):=share(4);
138 mcl_bases(2):=share(5);
139 if result<>8 then
140 send:=true;
141 end;
142 end;
143
143 procedure cat_error(z,s,b);
144 <*------------------------------------------*>
145 <* Catalog læsnings fejl procedure *>
146 <*------------------------------------------*>
147 zone z;
148 integer s,b;
149 begin
150 if false add (s shift (-18)) then
151 begin
152 b:=34;
153 eof:=true;
154 end
155 else
156 std_error(z,s,b);
157 end;
158
158 procedure lookup_entry(name);
159 <*---------------------------------------------*>
160 <* Find mcl-fil entry i katalog med givet navn *>
161 <*---------------------------------------------*>
162 integer array name;
163 begin
164 integer result;
165 long array field llaf;
166 real r;
167
167 send_move_mess(0,name,mcl_bases,result);
168 if result=0 then
169 begin
170 write(out,<:<10>:>,true,14,name.laf,<: :>);
171 outdate(out,round systime(6,buf.iaf(11),r));
172 write(out,<: :>);
173 outdate(out,round r);
174 llaf:=2;
175 write(out,<: :>,true,12,buf.llaf,<<ddddd>,buf.iaf(12));
176 end
177 else
178 if result=1 then
179 write(out,<:<10>***:>,prog_name.laf,<: :>,name.laf,<: not found:>)
180 else
181 error(result,name);
182 end;
183
183 procedure lookup_all;
184 <*---------------------------*>
185 <* Find mcl-filer i catalog *>
186 <*---------------------------*>
187 begin
188 zone cat(128,1,cat_error);
189 long array field llaf;
190 real r;
191 integer result;
192
192 send_move_mess(0,prog_name,mcl_bases,result);
193 if result>6 then
194 error(result,empty);
195 open(cat,4,<:catalog:>,1 shift 18);
196 eof:=false;
197 inrec6(cat,34);
198 while not eof do
199 begin
200 if cat.iaf(1)<>-1 then
201 begin
202 if cat.iaf(2)=mcl_bases(1) and
203 cat.iaf(3)=mcl_bases(2) and
204 cat.iaf(16)=29 shift 12 then
205 begin
206 llaf:=6;
207 write(out,<:<10>:>,true,14,cat.llaf,<: :>);
208 outdate(out,round systime(6,cat.iaf(13),r));
209 write(out,<: :>);
210 outdate(out,round r);
211 llaf:=16;
212 write(out,<: :>,true,12,cat.llaf,<<ddddd>,cat.iaf(17));
213 end;
214 end;
215 inrec6(cat,34);
216 end;
217 end;
218
218 procedure lookup_files;
219 <*---------------------------*>
220 <* Lookup parameter funktion *>
221 <*---------------------------*>
222 begin
223 integer array name(1:4);
224
224 if system(4,param,name.raf)<>(8 shift 12 + 10) then
225 lookup_all
226 else
227 repeat
228 param:=param+1;
229 lookup_entry(name);
230 until system(4,param,name.raf)<>(8 shift 12 + 10);
231 end;
232
232 procedure move_file(mode);
233 <*---------------------------------*>
234 <* Flyt filer til/fra system *>
235 <* *>
236 <* mode (call) : 1=To, 2=From *>
237 <*---------------------------------*>
238 integer mode;
239 begin
240 integer array name(1:4);
241 integer result;
242
242 while system(4,param,name.raf)=(8 shift 12 + 10) do
243 begin
244 param:=param+1;
245 send_move_mess(mode,name,user_bases,result);
246 if result<>0 then
247 error(result,name);
248 end;
249 end;
250
250 procedure move;
251 <*-----------------*>
252 <* Hoved procedure *>
253 <*-----------------*>
254 begin
255 integer array parameter(1:4);
256
256 while system(4,param,parameter.raf)=(4 shift 12 + 10) do
257 begin
258 param:=param+1;
259 if parameter.laf(1)=long <:inclu:> add 'd' then
260 move_file(1)
261 else
262 if parameter.laf(1)=long <:get:> then
263 move_file(2)
264 else
265 if parameter.laf(1)=long <:looku:> add 'p' then
266 lookup_files
267 else
268 error(10,parameter);
269 end;
270 if system(4,param,parameter.raf)<>0 then
271 error(10,parameter);
272 end;
273
273 <* Hoved program *>
274 trapmode:=1 shift 10;
275 raf:=laf:=iaf:=0;
276 for i:=1,2,3,4 do empty(i):=0;
277 if system(4,1,prog_name.raf)=(6 shift 12 + 10) then
278 param:=2
279 else
280 begin
281 system(4,0,prog_name.raf);
282 param:=1;
283 end;
284 get_userid;
285 set_buf_zone;
286 system(11,0,arr);
287 user_bases(1):=arr(5);
288 user_bases(2):=arr(6);
289 move;
290 write(out,<:<10>:>);
291 stop:
292 end;\f
algol end 49
*head ▶7f◀1
\f
tasgen 1987.05.14 11.40
*algol dtctxt connect.no list.yes
dtctxt d.861121.1146
1 begin
2 <********************************************************************>
3 <* Utility DELTASCAT til sletning af tas katalog indgange. *>
4 <* *>
5 <* Kald: deltascat <del-spec.> *>
6 <* *>
7 <* user.<name> *>
8 <* <del-spec.> ::= terminal.<name> *>
9 <* type.<number> *>
10 <* *>
11 <* Compiler call: deltascat=algol dtctxt connect.no *>
12 <********************************************************************>
13
13 <**************************************************************>
14 <* Revision history *>
15 <* *>
16 <* 86.12.01 deltascat release 1.0 *>
17 <**************************************************************>
18
18 <* Globale variable *>
19
19 zone buf(128,1,std_error); <* Zone til message m.m. *>
20 integer array user_id(1:4); <* Bruger id fra terminal *>
21 long password; <* Password fra terminal *>
22 integer array prog_name(1:4); <* Program navn *>
23 integer array conv(0:255); <* Tegn konverterings tabel *>
24 integer param; <* fp parameter tæller *>
25
25 integer array field iaf; <* Work *>
26 real array field raf; <* Work *>
27 long array field laf; <* Work *>
28 integer i; <* Work *>
29
29 <* Globale procedure *>
30
30 procedure get_userid;
31 <*-------------------------------------------------------------------*>
32 <* Set user id og password i de globale variable user_id og password *>
33 <* Id og password hentes fra terminalen tilknyttet prim. output *>
34 <*-------------------------------------------------------------------*>
35 begin
36 long array term_name(1:2);
37 integer i;
38 integer array ia(1:20);
39
39 system(7,0,term_name);
40 open(buf,0,term_name,0);
41 close(buf,false);
42 getzone6(buf,ia);
43 i:=ia(19);
44 getshare6(buf,ia,1);
45 ia(4):=131 shift 12;
46 ia(5):=i+1;
47 ia(6):=i+11;
48 ia(7):=0;
49 setshare6(buf,ia,1);
50 if monitor(16,buf,1,ia)=0 then
51 error(7);
52 if monitor(18,buf,1,ia)<>1 then
53 error(3);
54 if ia(1)<>0 then
55 error(3);
56 for i:=1,2,3,4 do
57 user_id(i):=buf.iaf(i);
58 password:=buf.laf(3);
59 end;
60
60 procedure error(err_nr);
61 <*-----------------------------------------------*>
62 <* Udskriv fejlmeddelelse og stop hvis fatal *>
63 <*-----------------------------------------------*>
64 integer err_nr;
65 begin
66 if err_nr>2 then
67 write(out,<:***:>,prog_name.laf,<: :>);
68 if err_nr<1 or err_nr>7 then
69 write(out,<:internal :>,err_nr)
70 else
71 write(out,case err_nr of (
72 <:in use:>,<:not found:>,
73 <:not allowed:>,<:no privilege:>,
74 <:no system:>,<:parameter:>,
75 <:claims:>));
76 write(out,<:<10>:>);
77 if err_nr>2 then
78 goto stop;
79 end;
80
80 procedure set_buf_zone;
81 <*-------------------------------------------*>
82 <* Sæt zonen buf klar til message til tas *>
83 <*-------------------------------------------*>
84 begin
85 open(buf,0,<:tas:>,0);
86 close(buf,false);
87 end;
88
88 procedure send_modify_mess(size,mode,func,result);
89 <*--------------------------------------------------------------*>
90 <* Send modify message til tas. Repeter hvis process stoppes *>
91 <* Message sendes via zonen buf *>
92 <* *>
93 <* size (call) : Antal hw der skal sendes/modtages i buf *>
94 <* mode (call) : 1=user, 2=terminal, 3=type *>
95 <* func (call) : 0=get, 1=modify, 2=set new, 3=delete *>
96 <* result (ret) : Resultat fra message, 0=OK *>
97 <*--------------------------------------------------------------*>
98 integer size,mode,func,result;
99 begin
100 integer array share(1:12),zone_ia(1:20);
101 boolean send;
102 integer i;
103
103 send:=false;
104 while not send do
105 begin
106 getshare6(buf,share,1);
107 getzone6(buf,zone_ia);
108 share(1):=0;
109 share(4):=(11 shift 12)+mode;
110 share(5):=zone_ia(19)+1;
111 share(6):=share(5)+size-2;
112 share(7):=func;
113 setshare6(buf,share,1);
114 for i:=1 step 1 until 4 do
115 buf.iaf(i):=user_id(i);
116 buf.iaf(5):=password shift (-24);
117 buf.iaf(6):=password extract 24;
118 if monitor(16,buf,1,share)=0 then
119 error(2);
120 if monitor(18,buf,1,share)<>1 then
121 error(3);
122 result:=share(1);
123 if result<>8 then
124 send:=true;
125 end;
126 end;
127
127 procedure del_user;
128 <*----------------------*>
129 <* Slet en user indgang *>
130 <*----------------------*>
131 begin
132 integer array u_id(1:4);
133 integer sep,i,result;
134
134 sep:=system(4,param,u_id.raf);
135 if sep=(8 shift 12 + 10) then
136 begin
137 param:=param+1;
138 for i:=1 step 1 until 4 do
139 buf.iaf(6+i):=u_id(i);
140 send_modify_mess(20,1,3,result);
141 write(out,<:user.:>,u_id.laf,<: :>);
142 if result<>0 then
143 begin
144 if result=13 then
145 error(3)
146 else
147 error(result);
148 end
149 else
150 write(out,<:deleted<10>:>);
151 end
152 else
153 error(6);
154 end;
155
155 procedure del_term;
156 <*--------------------------*>
157 <* Slet en terminal indgang *>
158 <*--------------------------*>
159 begin
160 long array t_id(1:2);
161 integer sep,i,j,ch,result;
162 long array field llaf;
163
163 llaf:=12;
164 sep:=system(4,param,t_id.raf);
165 if sep=(8 shift 12 + 10) then
166 begin
167 param:=param+1;
168 j:=i:=1;
169 get_char(t_id,i,conv,ch);
170 if ch='t' then
171 get_char(t_id,i,conv,ch);
172 buf.llaf(2):=0;
173 while i<13 do
174 begin
175 put_char(buf.llaf,j,conv,ch);
176 get_char(t_id,i,conv,ch);
177 end;
178 send_modify_mess(20,2,3,result);
179 write(out,<:terminal.:>,buf.llaf,<: :>);
180 if result<>0 then
181 begin
182 if result=13 then
183 error(3)
184 else
185 error(result);
186 end
187 else
188 write(out,<:deleted<10>:>);
189 end
190 else
191 error(6);
192 end;
193
193 procedure del_type;
194 <*----------------------*>
195 <* Slet en type indgang *>
196 <*----------------------*>
197 begin
198 real array type(1:2);
199 integer sep,i,result;
200
200 sep:=system(4,param,type);
201 if sep=(8 shift 12 + 4) then
202 begin
203 param:=param+1;
204 buf.iaf(7):=type(1);
205 send_modify_mess(14,3,3,result);
206 write(out,<:type.:>,<<d>,buf.iaf(7),<: :>);
207 if result<>0 then
208 begin
209 if result=13 then
210 error(3)
211 else
212 error(result);
213 end
214 else
215 write(out,<:deleted<10>:>);
216 end
217 else
218 error(6);
219 end;
220
220 procedure delete;
221 <*-----------------------------------------------*>
222 <* Bestem hvilken indgange der skal slettes *>
223 <*-----------------------------------------------*>
224 begin
225 real array name(1:2);
226
226 while system(4,param,name)<>0 do
227 begin
228 param:=param+1;
229 if name.laf(1)= long <:user:> then
230 del_user
231 else
232 if name.laf(1)= long <:termi:> add 'n' then
233 del_term
234 else
235 if name.laf(1)= long <:type:> then
236 del_type
237 else
238 error(6);
239 end;
240 end;
241
241 <* Hoved program *>
242 trapmode:=1 shift 10;
243 raf:=laf:=iaf:=0;
244 for i:=0 step 1 until 255 do
245 conv(i):=i;
246 if system(4,1,prog_name.raf)=(6 shift 12 + 10) then
247 param:=2
248 else
249 begin
250 system(4,0,prog_name.raf);
251 param:=1;
252 end;
253 get_userid;
254 set_buf_zone;
255 delete;
256 stop:
257 end;\f
algol end 49
*head ▶7f◀1
\f
tasgen 1987.05.14 11.41
*algol stctxt list.yes
stctxt d.861223.1340
1 begin
2 <********************************************************************>
3 <* Utility SETTASCAT til indsættelse og opdatering af indgange *>
4 <* *>
5 <* Kald: settascat <in-spec.> *>
6 <* *>
7 <* <in-spec.> ::= current input or file *>
8 <* *>
9 <* Compiler call: settascat=algol stctxt connect.yes *>
10 <* *>
11 <********************************************************************>
12
12 <**************************************************************>
13 <* Revision history *>
14 <* *>
15 <* 86.12.01 settascat release 1.0 *>
16 <**************************************************************>
17
17 <* Globale variable *>
18
18 zone buf(128,1,std_error); <* Zone til message m.m. *>
19 integer array user_id(1:4); <* Bruger id fra terminal *>
20 long password; <* Password fra terminal *>
21 integer array prog_name(1:4); <* Program navn *>
22 integer array conv(0:255); <* Tegn konverterings tabel *>
23 integer param; <* fp parameter tæller *>
24 integer line_nr; <* Input linie nummer *>
25 integer array mcl_bases(1:2); <* System mcl baser *>
26 integer num_keys; <* Antal keywords *>
27 long array keywords(0:60); <* Keywords array *>
28
28 integer array field iaf; <* Work *>
29 real array field raf; <* Work *>
30 boolean array field baf; <* Work *>
31 long array field laf; <* Work *>
32 integer i; <* Work *>
33
33 <* Procedure til afhjælpelse af fejl i externe procedure *>
34
34 integer procedure put_ch(dest,pos,char,rep);
35 long array dest;
36 integer pos,char,rep;
37 begin
38 trap(local);
39 put_ch:=putchar(dest,pos,char,rep);
40 if false then
41 local: put_ch:=-1;
42 end;
43
43 integer procedure put_txt(dest,pos,text,length);
44 long array dest,text;
45 integer pos,length;
46 begin
47 trap(local);
48 put_txt:=puttext(dest,pos,text,length);
49 if false then
50 local: put_txt:=-1;
51 end;
52
52 <* Globale procedure *>
53
53 procedure init_keywords;
54 <*-------------------------------------------*>
55 <* initialiser keywords *>
56 <*-------------------------------------------*>
57 begin
58 integer i;
59
59 num_keys:=50;
60 for i:=1 step 1 until num_keys do
61 begin
62 keywords(i):=0;
63 keywords(i):= long (case i of
64 <* 1 *> (<:end:>,<:size:>,<:user:>,<:passw:>,<:cpass:>,
65 <* 6 *> <:monda:>,<:tuesd:>,<:wedne:>,<:thurs:>,<:frida:>,
66 <* 11 *> <:satur:>,<:sunda:>,<:block:>,<:sessi:>,<:privi:>,
67 <* 16 *> <:mclna:>,<:base:>,<:group:>,<:mclte:>,<:freet:>,
68 <* 21 *> <:termi:>,<:termt:>,<:termg:>,<:bypas:>,<:type:>,
69 <* 26 *> <:scree:>,<:colum:>,<:lines:>,<:sbup:>,<:sbdow:>,
70 <* 31 *> <:sblef:>,<:sbrig:>,<:sbhom:>,<:sbdel:>,<:ceod:>,
71 <* 36 *> <:ceol:>,<:invon:>,<:invof:>,<:hlon:>,<:hloff:>,
72 <* 41 *> <:delet:>,<:inser:>,<:curso:>,<:up:>,<:down:>,
73 <* 46 *> <:left:>,<:right:>,<:home:>,<:xxxxx:>,<:init:>));
74 end;
75 end;
76
76 integer procedure find_keyword_value(keyword);
77 <*----------------------------------------------------------------*>
78 <* Find 'token' værdien for det angivne keyword *>
79 <* *>
80 <* keyword (call) : Long indeholdende op til 5 tegn af keyword *>
81 <* Return : Værdien for det angivne keyword eller *>
82 <* 0 hvis keyword er ukendt *>
83 <*----------------------------------------------------------------*>
84 long keyword;
85 begin
86 integer i;
87
87 i:=num_keys+1;
88 keyword:=(keyword shift (-8)) shift 8;
89 for i:=i-1 while not (keyword=keywords(i)) and (i<>0) do; <* nothing *>
90 find_keyword_value:=i;
91 if i=0 and keyword<>0 then
92 write_mess(8,false);
93 end;
94
94 procedure next_line;
95 <*-------------------------------------------------------*>
96 <* Læs til starten af næste linie i input *>
97 <* Linier der starter med ; eller er blanke overspringes *>
98 <* Linie tæller optælles med 1 for hver linie *>
99 <* *>
100 <*-------------------------------------------------------*>
101 begin
102 integer i;
103
103 repeatchar(in);
104 readchar(in,i);
105 while (i<>'nl') and (i<>'em') do
106 readchar(in,i);
107 line_nr:=line_nr+1;
108 readchar(in,i);
109 if i<>'em' then
110 begin
111 while i=' ' do
112 readchar(in,i);
113 if i='nl' or i='em' or i=';' then
114 begin
115 next_line;
116 readchar(in,i);
117 end;
118 end;
119 repeatchar(in);
120 end;
121
121 integer procedure read_start_key;
122 <*-------------------------------------------------------------------*>
123 <* Find værdien af nøgleordet i starten af tekst linien i input *>
124 <* *>
125 <* Return : -1 = Sidste linie i fil er læst *>
126 <* 0 = Nøgleord er ikke fundet *>
127 <* >0 = Nøgleordets værdi *>
128 <*-------------------------------------------------------------------*>
129 begin
130 long array key(1:5);
131 integer i;
132
132 readchar(in,i);
133 if i<>'em' then
134 begin
135 while i=' ' do
136 readchar(in,i);
137 if i='nl' or i='em' or i=';' then
138 begin
139 next_line;
140 readchar(in,i);
141 end;
142 end;
143 repeatchar(in);
144 read_start_key:=if readstring(in,key,1)>0 then
145 find_keyword_value(key(1))
146 else
147 -1;
148 repeatchar(in);
149 end;
150
150 integer procedure read_text(text,max);
151 <*---------------------------------------------------------------------*>
152 <* Læs tekst fra input til text, til slutning af linie eller til *>
153 <* maximalt antal tegn læst. Indledende blanktegn overspringes. *>
154 <* *>
155 <* text (ret) : Den læste tekst *>
156 <* max (call) : Det maximale antal tegn der læses *>
157 <* Return : Antal tegn læst til text *>
158 <* *>
159 <*---------------------------------------------------------------------*>
160 integer max;
161 long array text;
162 begin
163 integer ch,pos;
164 boolean first;
165
165 pos:=1;
166 first:=true;
167 text(1):=0;
168 repeatchar(in);
169 readchar(in,ch);
170 if (ch<>'nl') and (ch<>'em') then
171 begin
172 readchar(in,ch);
173 while ch<>'nl' and ch<>'em' and pos<=max do
174 begin
175 if first and (ch<>' ') then
176 first:=false;
177 if -,first then
178 put_ch(text,pos,ch,1);
179 readchar(in,ch);
180 end;
181 end;
182 read_text:=pos-1;
183 if pos<=max then
184 put_ch(text,pos,0,1);
185 repeatchar(in);
186 end;
187
187 boolean procedure read_nr(nr);
188 <*-----------------------------------------------------------------*>
189 <* Læs et heltal fra input. Er der ikke flere tal på linien *>
190 <* returneres -1 ellers det læste tal. Er der angivet ulovligt *>
191 <* tal (eller andet end tal) sættes read_nr til false *>
192 <* *>
193 <* nr (ret) : Læst tal eller -1 hvis ikke flere tal *>
194 <* Return : True = ok False = illegalt tal *>
195 <*-----------------------------------------------------------------*>
196 integer nr;
197 begin
198 integer ch,class;
199
199 read_nr:=true;
200 repeat
201 class:=readchar(in,ch);
202 until class<>7 or ch=';' ;
203 if ch=';' or class=8 then
204 nr:=-1
205 else
206 if class<2 or class>3 then
207 begin
208 nr:=-1;
209 read_nr:=false;
210 end
211 else
212 begin
213 repeatchar(in);
214 read(in,nr);
215 end;
216 repeatchar(in);
217 end;
218
218 boolean procedure read_name(name,ok);
219 <*---------------------------------------------------------------------*>
220 <* Læs et navn fra input til name. Resterende tegn nulstilles *>
221 <* Indledende blanktegn overspringes. Der stoppes ved kommentar *>
222 <* *>
223 <* name (ret) : Det læste navn i integer array name(1:4) *>
224 <* ok (ret) : True hvis navnet starter med bogstav *>
225 <*---------------------------------------------------------------------*>
226 integer array name;
227 boolean ok;
228 begin
229 integer ch,pos;
230
230 ok:=false;
231 for pos:=1,2,3,4 do
232 name(pos):=0;
233 pos:=1;
234 repeatchar(in);
235 readchar(in,ch);
236 while ch=' ' do
237 readchar(in,ch);
238 if ch>='a' and ch<='å' then
239 ok:=true;
240 while ((ch>='0'and ch<='9') or (ch>='a' and ch<='å')) and pos<=11 do
241 begin
242 put_ch(name.laf,pos,ch,1);
243 readchar(in,ch);
244 end;
245 repeatchar(in);
246 read_name:=not name(1)=0;
247 end;
248
248 procedure clear_high(i);
249 <*---------------------------*>
250 <* Nulstil 12 high bit i ord *>
251 <*---------------------------*>
252 integer i;
253 begin
254 i:=(i shift 12) shift (-12);
255 end;
256
256 procedure clear_low(i);
257 <*---------------------------*>
258 <* Nulstil 12 low bit i ord *>
259 <*---------------------------*>
260 integer i;
261 begin
262 i:=(i shift (-12)) shift 12;
263 end;
264
264 procedure set_entry;
265 <*------------------------------------------------------*>
266 <* Indsæt værdier læst fra input i indgange i kataloget *>
267 <*------------------------------------------------------*>
268 begin
269 integer key,result,i,first,last,type;
270 integer array id(1:4);
271 integer array field entry;
272 boolean exist,ok;
273 long array password(1:8);
274
274 line_nr:=1;
275 key:=read_start_key;
276 while key=0 or key=2 do
277 begin
278 if key=2 then
279 begin
280 write(out,<:Size field ignored<10>:>);
281 setposition(out,0,0);
282 end;
283 next_line;
284 key:=read_start_key;
285 end;
286 while (key<>1 <* end *>) and (key<>-1) do
287 begin
288 if key=3 then
289 begin <* user entry *>
290 if not read_name(id,ok) then
291 write_mess(12,false);
292 if not ok then
293 write_mess(12,false);
294 for i:=1,2,3,4 do
295 buf.iaf(i+6):=id(i);
296 send_modify_mess(132,1,0,result);
297 if result=0 or result=2 then
298 begin <* ok *>
299 entry:=10;
300 exist:=true;
301 write(out,<:User :>,id.laf,<: :>);
302 if result=2 then
303 begin <* ny bruger *>
304 <* init entry *>
305 exist:=false;
306 for i:=6 step 1 until 61 do
307 buf.entry(i):=0;
308 buf.entry(12):=1 shift 12; <* Max sessions *>
309 buf.entry(23):=2 shift 12; <* mcl def. text empty *>
310 buf.entry(19):=1 shift 23; <* term. group 0 *>
311 end;
312 next_line;
313 key:=read_start_key;
314 while (key>=4) and (key<=20) do
315 begin
316 <* indsæt i entry *>
317 if (key>=6) and (key<=12) then
318 begin <* læs first og last for login tid *>
319 if not(read_nr(first) and read_nr(last)) then
320 write_mess(11,false);
321 if first<0 or first>24 or last<0 or last>24 then
322 write_mess(11,false);
323 type:=if first=0 and last=24 then
324 3
325 else
326 if first=last then
327 0
328 else
329 if first<last then
330 1
331 else
332 2;
333 end;
334 begin
335 case key-3 of
336 begin
337 begin <* password *>
338 for i:=1 step 1 until 8 do
339 password(i):=0;
340 buf.entry(6):=0;
341 buf.entry(7):=0;
342 if read_text(password,48)>0 then
343 begin <* kod password *>
344 for last:=1 step 1 until 31 do
345 begin
346 key:=password.baf(last) extract 12;
347 for i:=last+1 step 1 until 32 do
348 password.baf(i):=false add
349 ((password.baf(i) extract 12) + key);
350 end;
351 for i:=1 step 1 until 16 do
352 begin
353 buf.entry(6):=buf.entry(6)+
354 password.iaf(i);
355 buf.entry(7):=buf.entry(7)+
356 buf.entry(6);
357 end;
358 end;
359 end;
360 begin <* kodet password *>
361 read(in,password(1));
362 buf.entry(6):=password(1) shift (-24);
363 buf.entry(7):=password(1) extract 24;
364 end;
365 begin <* monday *>
366 clear_high(buf.entry(8));
367 buf.entry(8):=buf.entry(8)+
368 ((first shift 7)+(last shift 2) + type) shift 12;
369 end;
370 begin <* tuesday *>
371 clear_low(buf.entry(8));
372 buf.entry(8):=buf.entry(8)+
373 ((first shift 7)+(last shift 2) + type);
374 end;
375 begin <* wednesday *>
376 clear_high(buf.entry(9));
377 buf.entry(9):=buf.entry(9)+
378 ((first shift 7)+(last shift 2) + type) shift 12;
379 end;
380 begin <* thursday *>
381 clear_low(buf.entry(9));
382 buf.entry(9):=buf.entry(9)+
383 ((first shift 7)+(last shift 2) + type);
384 end;
385 begin <* friday *>
386 clear_high(buf.entry(10));
387 buf.entry(10):=buf.entry(10)+
388 ((first shift 7)+(last shift 2) + type) shift 12;
389 end;
390 begin <* saturday *>
391 clear_low(buf.entry(10));
392 buf.entry(10):=buf.entry(10)+
393 ((first shift 7)+(last shift 2) + type);
394 end;
395 begin <* sunday *>
396 clear_high(buf.entry(11));
397 buf.entry(11):=buf.entry(11)+
398 ((first shift 7)+(last shift 2) + type) shift 12;
399 end;
400 begin <* block *>
401 if not read_nr(i) or i<0 then
402 write_mess(11,false);
403 clear_low(buf.entry(11));
404 buf.entry(11):=buf.entry(11)+i;
405 end;
406 begin <* sessions *>
407 clear_high(buf.entry(12));
408 if not read_nr(i) or i>9 or i<1 then
409 write_mess(11,false);
410 buf.entry(12):=buf.entry(12)+(i shift 12);
411 end;
412 begin <* privilegier *>
413 type:=0;
414 clear_low(buf.entry(12));
415 if not read_nr(i) then
416 write_mess(11,false);
417 while (i>=0) do
418 begin
419 if i>11 then
420 write_mess(11,false);
421 type:=type+(1 shift (11-i));
422 if not read_nr(i) then
423 write_mess(11,false);
424 end;
425 buf.entry(12):=buf.entry(12)+type;
426 end;
427 begin <* mcl name *>
428 if not read_name(id,ok) then
429 write_mess(12,false);
430 if not ok then
431 write_mess(12,false);
432 for i:=1,2,3,4 do
433 buf.entry(i+12):=id(i);
434 end;
435 begin <* mcl bases *>
436 if not(read_nr(first) and read_nr(last)) then
437 write_mess(11,false);
438 if first>last then
439 write_mess(11,false);
440 buf.entry(17):=first;
441 buf.entry(18):=last;
442 end;
443 begin <* groups *>
444 for i:=1 step 1 until 4 do
445 id(i):=0;
446 if not read_nr(i) then
447 write_mess(11,false);
448 while i>=0 do
449 begin
450 if i>95 then
451 write_mess(11,false);
452 first:=(i//24)+1;
453 last:=23-(i mod 24);
454 if -,(false add (id(first) shift (-last))) then
455 id(first):=id(first)+(1 shift last);
456 if not read_nr(i) then
457 write_mess(11,false);
458 end;
459 for i:=1 step 1 until 4 do
460 buf.entry(18+i):=id(i);
461 end;
462 begin <* mcl text *>
463 laf:=46;
464 i:=read_text(buf.entry.laf,80);
465 buf.entry(23):=
466 ((((i+2)//3*2)+2) shift 12) + i;
467 laf:=0;
468 end;
469 begin <* free text *>
470 laf:=100;
471 read_text(buf.entry.laf,30);
472 laf:=0;
473 end;
474 end;
475 end;
476 next_line;
477 key:=read_start_key;
478 end;
479 if exist then
480 send_modify_mess(132,1,1,result)
481 else
482 send_modify_mess(132,1,2,result);
483 if result<>0 then
484 begin
485 if result=1 then
486 write_mess(1,true)
487 else
488 write_mess(result,false);
489 end
490 else
491 if exist then
492 write_mess(3,true)
493 else
494 write_mess(2,true);
495 end
496 else
497 write_mess(result,false);
498 end
499 else
500 if key=21 then
501 begin <* terminal entry *>
502 if not read_name(id,ok) then
503 write_mess(12,false);
504 for i:=1,2,3,4 do
505 buf.iaf(i+6):=id(i);
506 send_modify_mess(46,2,0,result);
507 if result=0 or result=2 then
508 begin
509 exist:=true;
510 entry:=10;
511 write(out,<:Terminal :>,id.laf,<: :>);
512 if result=2 then
513 begin
514 <* init entry *>
515 exist:=false;
516 for i:=7 step 1 until 18 do
517 buf.entry(i):=0;
518 buf.entry(6):=1 shift 12; <* terminal type *>
519 end;
520 next_line;
521 key:=read_start_key;
522 while (key>=22 and key<=24) or key=13 or key=20 do
523 begin
524 <* indsæt i entry *>
525 if key=22 then
526 begin <* Terminal type *>
527 if not read_nr(i) or i<0 or i>2047 then
528 write_mess(11,false);
529 clear_high(buf.entry(6));
530 buf.entry(6):=buf.entry(6)+
531 i shift 12;
532 end;
533 if key=23 then
534 begin <* terminal group *>
535 if not read_nr(i) or i<0 or i>95 then
536 write_mess(11,false);
537 clear_low(buf.entry(7));
538 buf.entry(7):=buf.entry(7)+i;
539 end;
540 if key=20 then
541 begin <* free text *>
542 laf:=14;
543 read_text(buf.entry.laf,30);
544 laf:=0;
545 end;
546 if key=13 then
547 begin <* block *>
548 if not read_nr(i) or i<0 or i>4095 then
549 write_mess(11,false);
550 clear_low(buf.entry(6));
551 buf.entry(6):=buf.entry(6)+i;
552 end;
553 if key=24 then
554 begin <* bypass *>
555 clear_high(buf.entry(7));
556 if not read_nr(i) or i<>0 then
557 buf.entry(7):=buf.entry(7)+(1 shift 12);
558 end;
559 next_line;
560 key:=read_start_key;
561 end;
562 if exist then
563 send_modify_mess(46,2,1,result)
564 else
565 send_modify_mess(46,2,2,result);
566 if result<>0 then
567 begin
568 if result=1 then
569 write_mess(1,true)
570 else
571 write_mess(result,false);
572 end
573 else
574 if exist then
575 write_mess(3,true)
576 else
577 write_mess(2,true);
578 end
579 else
580 write_mess(result,false);
581 end
582 else
583 if key=25 then
584 begin <* type entry *>
585 if not read_nr(type) or type<1 or key>2047 then
586 write_mess(11,false);
587 buf.iaf(7):=type;
588 send_modify_mess(140,3,0,result);
589 if result=0 or result=2 then
590 begin
591 exist:=true;
592 entry:=12;
593 write(out,<:Type :>,<<dd>,type,<: :>);
594 if result=2 then
595 begin
596 <* init entry *>
597 exist:=false;
598 for i:=2 step 1 until 64 do
599 buf.entry(i):=0;
600 buf.entry(1):=type; <* terminal type *>
601 buf.entry(3):=(80 shift 12)+24;
602 end;
603 next_line;
604 key:=read_start_key;
605 while ((key>=26) and (key<=50)) or (key=20) do
606 begin
607 <* indsæt i entry *>
608 if key=26 then
609 begin <* screen type *>
610 type:=0;
611 if not read_nr(i) then
612 write_mess(11,false);
613 while (i>=0) do
614 begin
615 if i>23 then
616 write_mess(11,false);
617 type:=type+(1 shift (23-i));
618 if not read_nr(i) then
619 write_mess(11,false);
620 end;
621 buf.entry(2):=type;
622 end;
623 if (key>=27) and (key<=34) then
624 begin <* 'send by' værdier *>
625 boolean array field baf;
626 baf:=0;
627 if not read_nr(i) or i>255 or i<0 then
628 write_mess(11,false);
629 buf.entry.baf(key-22):=if i>0 then
630 false add i
631 else
632 false;
633 end;
634 if (key>=44) and (key<=49) then
635 begin <* et tegns værdier *>
636 boolean array field baf;
637 baf:=0;
638 if not read_nr(i) or i>255 or i<0 then
639 write_mess(11,false);
640 buf.entry.baf(key+7):=if i>0 then
641 false add i
642 else
643 false;
644 end;
645 if (key>=35) and (key<=42) then
646 begin <* 6 tegns sekevnser *>
647 if not read_nr(i) or i>255 or i<0 then
648 write_mess(11,false);
649 first:=1;
650 laf:=case (key-34) of
651 (12,16,20,24,28,32,36,40);
652 buf.entry.laf(1):=0;
653 while (i<>-1) and (first<=6) do
654 begin
655 put_ch(buf.entry.laf,first,i,1);
656 if first<=6 then
657 begin
658 if not read_nr(i) or i>255 or i<-1 then
659 write_mess(11,false);
660 end;
661 end;
662 laf:=0;
663 end;
664 if key=43 then
665 begin <* cursor sekvens *>
666 if not read_nr(i) or i>255 or i<0 then
667 write_mess(11,false);
668 first:=1;
669 laf:=44;
670 buf.entry.laf(1):=0;
671 while (i<>-1) and (first<=9) do
672 begin
673 put_ch(buf.entry.laf,first,i,1);
674 if first<=9 then
675 begin
676 if not read_nr(i) or i>255 or i<-1 then
677 write_mess(11,false);
678 end;
679 end;
680 laf:=0;
681 end;
682 if key=50 then
683 begin <* initialiserings sekvens *>
684 laf:=56;
685 put_ch(buf.entry.laf,1,0,75);
686 if not read_nr(i) or i>255 or i<0 then
687 write_mess(11,false);
688 first:=1;
689 while (i<>-1) and (first<=75) do
690 begin
691 put_ch(buf.entry.laf,first,i,1);
692 if first<=75 then
693 begin
694 if not read_nr(i) or i>255 or i<-1 then
695 write_mess(11,false);
696 end;
697 end;
698 laf:=0;
699 end;
700 if key=20 then
701 begin <* free text *>
702 laf:=106;
703 read_text(buf.entry.laf,30);
704 laf:=0;
705 end;
706 next_line;
707 key:=read_start_key;
708 end;
709 if exist then
710 send_modify_mess(140,3,1,result)
711 else
712 send_modify_mess(140,3,2,result);
713 if result<>0 then
714 begin
715 if result=1 then
716 write_mess(1,true)
717 else
718 write_mess(result,false);
719 end
720 else
721 if exist then
722 write_mess(3,true)
723 else
724 write_mess(2,true);
725 end
726 else
727 write_mess(result,false);
728 end
729 else
730 write_mess(8,false);
731 end;
732 end;
733
733 procedure get_userid;
734 <*-------------------------------------------------------------------*>
735 <* Set user id og password i de globale variable user_id og password *>
736 <* Id og password hentes fra terminalen tilknyttet prim. output *>
737 <*-------------------------------------------------------------------*>
738 begin
739 long array term_name(1:2);
740 integer i;
741 integer array ia(1:20);
742
742 system(7,0,term_name);
743 open(buf,0,term_name,0);
744 close(buf,false);
745 getzone6(buf,ia);
746 i:=ia(19);
747 getshare6(buf,ia,1);
748 ia(4):=131 shift 12;
749 ia(5):=i+1;
750 ia(6):=i+11;
751 ia(7):=0;
752 setshare6(buf,ia,1);
753 if monitor(16,buf,1,ia)=0 then
754 write_mess(5,false);
755 if monitor(18,buf,1,ia)<>1 then
756 write_mess(10,false);
757 if ia(1)<>0 then
758 write_mess(10,false);
759 for i:=1,2,3,4 do
760 user_id(i):=buf.iaf(i);
761 password:=buf.laf(3);
762 end;
763
763 procedure write_mess(nr,cont);
764 <*-------------------------------------------*>
765 <* Udskriv meddelelse på current output *>
766 <*-------------------------------------------*>
767 integer nr;
768 boolean cont;
769 begin
770 if not cont then
771 write(out,<: error<10>***:>,prog_name.laf,<: :>);
772 if nr=13 then
773 nr:=9;
774 if nr>13 then
775 write(out,<:internal :>,<<dd>,nr)
776 else
777 write(out,case nr of (
778 <:in use:>,<:inserted:>,<:updated:>,<:no privilege:>,
779 <:claims:>,<:catalog full:>,<:update conflict:>,
780 <:unknown field name:>,<:not allowed:>,<:no system:>,
781 <:illegal number:>,<:illegal name:>));
782 if nr=11 or nr=12 or nr=8 or nr=1 or nr=6 or nr=7 then
783 write(out,<: at line :>,<<dd>,line_nr);
784 write(out,<:<10>:>);
785 setposition(out,0,0);
786 if (not cont) or nr>13 then
787 goto stop;
788 end;
789
789 procedure set_buf_zone;
790 <*-------------------------------------------*>
791 <* Sæt zonen buf klar til message til tas *>
792 <*-------------------------------------------*>
793 begin
794 open(buf,0,<:tas:>,0);
795 close(buf,false);
796 end;
797
797 procedure send_modify_mess(size,mode,func,result);
798 <*--------------------------------------------------------------*>
799 <* Send modify message til tas. Repeter hvis process stoppes *>
800 <* Message sendes via zonen buf *>
801 <* *>
802 <* size (call) : Antal hw der skal sendes/modtages i buf *>
803 <* mode (call) : 1=user, 2=terminal, 3=type *>
804 <* func (call) : 0=get, 1=modify, 2=set new, 3=delete *>
805 <* result (ret) : Resultat fra message, 0=OK *>
806 <*--------------------------------------------------------------*>
807 integer size,mode,func,result;
808 begin
809 integer array share(1:12),zone_ia(1:20);
810 boolean send;
811 integer i;
812
812 send:=false;
813 while not send do
814 begin
815 getshare6(buf,share,1);
816 getzone6(buf,zone_ia);
817 share(1):=0;
818 share(4):=(11 shift 12)+mode;
819 share(5):=zone_ia(19)+1;
820 share(6):=share(5)+size-2;
821 share(7):=func;
822 setshare6(buf,share,1);
823 for i:=1 step 1 until 4 do
824 buf.iaf(i):=user_id(i);
825 buf.iaf(5):=password shift (-24);
826 buf.iaf(6):=password extract 24;
827 if monitor(16,buf,1,share)=0 then
828 write_mess(5,false);
829 if monitor(18,buf,1,share)<>1 then
830 write_mess(10,false);
831 result:=share(1);
832 if result<>8 then
833 send:=true;
834 end;
835 end;
836
836 <* Hoved program *>
837 trapmode:=1 shift 10;
838 raf:=laf:=iaf:=baf:=0;
839 line_nr:=0;
840 mcl_bases(1):=mcl_bases(2):=0;
841 for i:=0 step 1 until 255 do
842 conv(i):=i;
843 if system(4,1,prog_name.raf)<>(6 shift 12 + 10) then
844 system(4,0,prog_name.raf);
845 init_keywords;
846 get_userid;
847 set_buf_zone;
848 set_entry;
849 stop:
850 end;\f
algol end 78
*head ▶7f◀1
\f
tasgen 1987.05.14 11.41
*algol ltctxt connect.no list.yes
ltctxt d.870112.0928
1 begin
2 <********************************************************************>
3 <* Utility LISTTASCAT til udskrift af tas katalog indgange. *>
4 <* *>
5 <* Kald: <out-file> = listtascat <out-spec.> *>
6 <* *>
7 <* user.<name> *>
8 <* terminal.<name> *>
9 <* <out-spec.> ::= type.<number> *>
10 <* size *>
11 <* all *>
12 <* *>
13 <* Compiler call: listtascat=algol ltctxt connect.no *>
14 <********************************************************************>
15
15 <**************************************************************>
16 <* Revision history *>
17 <* *>
18 <* 87.02.01 listtascat release 1.0 *>
19 <**************************************************************>
20
20
20 <* Globale variable *>
21
21 zone buf(128,1,std_error); <* Zone til message m.m. *>
22 integer array user_id(1:4); <* Bruger id fra terminal *>
23 long password; <* Password fra terminal *>
24 boolean file_out; <* True= connect to file *>
25 boolean no_found; <* Entry ikke fundet *>
26 integer array out_stack(1:4); <* out zone stack *>
27 integer array prog_name(1:4); <* Program navn *>
28 integer array conv(0:255); <* Tegn konverterings tabel *>
29 integer param; <* fp parameter tæller *>
30 integer user_size; <* Antal seg i user cat *>
31 integer term_size; <* Antal seg i term cat *>
32 integer type_size; <* Antal seg i type cat *>
33 integer user_hw; <* Antal hw i user entry *>
34 integer term_hw; <* Antal hw i term entry *>
35 integer type_hw; <* Antal hw i type entry *>
36
36 integer array field iaf; <* Work *>
37 real array field raf; <* Work *>
38 boolean array field baf; <* Work *>
39 long array field laf; <* Work *>
40 integer i; <* Work *>
41
41 <* Globale procedure *>
42
42 procedure get_userid;
43 <*-------------------------------------------------------------------*>
44 <* Set user id og password i de globale variable user_id og password *>
45 <* Id og password hentes fra terminalen tilknyttet prim. output *>
46 <*-------------------------------------------------------------------*>
47 begin
48 long array term_name(1:2);
49 integer i;
50 integer array ia(1:20);
51
51 system(7,0,term_name);
52 open(buf,0,term_name,0);
53 close(buf,false);
54 getzone6(buf,ia);
55 i:=ia(19);
56 getshare6(buf,ia,1);
57 ia(4):=131 shift 12;
58 ia(5):=i+1;
59 ia(6):=i+11;
60 ia(7):=0;
61 setshare6(buf,ia,1);
62 if monitor(16,buf,1,ia)=0 then
63 error(2);
64 if monitor(18,buf,1,ia)<>1 then
65 error(5);
66 if ia(1)<>0 then
67 error(5);
68 for i:=1,2,3,4 do
69 user_id(i):=buf.iaf(i);
70 password:=buf.laf(3);
71 end;
72
72 procedure error(err_nr);
73 <*-----------------------------------------------*>
74 <* Udskriv fejlmeddelelse på cur. output og stop *>
75 <*-----------------------------------------------*>
76 integer err_nr;
77 begin
78 close_output;
79 write(out,<:***:>,prog_name.laf,<: :>);
80 if err_nr<1 or err_nr>7 then
81 write(out,<:internal :>,err_nr)
82 else
83 write(out,case err_nr of (
84 <:connect output:>,<:claims:>,
85 <:no system:>,<:no privilege:>,
86 <:not allowed:>,<:parameter:>,
87 <:not found:>));
88 write(out,<:<10>:>);
89 goto stop;
90 end;
91
91
91 procedure set_output;
92 <*-----------------------------------------------*>
93 <* Set output zonen til enten cur. out eller fil *>
94 <*-----------------------------------------------*>
95 begin
96 integer seperator,result;
97 real array file_name(1:2);
98
98 seperator:=system(4,1,prog_name.raf);
99 if seperator shift (-12) = 6 then
100 begin
101 system(4,0,file_name);
102 fp_proc(29)stack_zone:(0,out,out_stack);
103 result:=2;
104 fp_proc(28)connect_output:(result,out,file_name);
105 if result=0 then
106 file_out:=true
107 else
108 error(1);
109 end
110 else
111 begin
112 system(4,0,prog_name.raf);
113 file_out:=false;
114 end;
115 end;
116
116 procedure close_output;
117 <*----------------------------------*>
118 <* Luk output zonen og unstack evt. *>
119 <*----------------------------------*>
120 begin
121 integer array ia(1:20);
122 integer size;
123
123 if file_out then
124 begin
125 fp_proc(34)close_up:(0,out,'em');
126 fp_proc(79)terminate_zone:(0,out,0);
127 getzone6(out,ia);
128 size:=ia(9);
129 monitor(42,out,0,ia);
130 ia(1):=size;
131 ia(6):=systime(7,0,0.0);
132 monitor(44,out,0,ia);
133 fp_proc(30)unstack_zone:(0,out,out_stack);
134 end;
135 end;
136
136 procedure set_buf_zone;
137 <*-------------------------------------------*>
138 <* Sæt zonen buf klar til message til tas *>
139 <*-------------------------------------------*>
140 begin
141 open(buf,0,<:tas:>,0);
142 close(buf,false);
143 end;
144
144 procedure send_modify_mess(size,mode,func,result);
145 <*--------------------------------------------------------------*>
146 <* Send modify message til tas. Repeter hvis process stoppes *>
147 <* Message sendes via zonen buf *>
148 <* *>
149 <* size (call) : Antal hw der skal sendes/modtages i buf *>
150 <* mode (call) : 1=user, 2=terminal, 3=type *>
151 <* func (call) : 0=get, 1=modify, 2=set new, 3=delete *>
152 <* result (ret) : Resultat fra message, 0=OK *>
153 <*--------------------------------------------------------------*>
154 integer size,mode,func,result;
155 begin
156 integer array share(1:12),zone_ia(1:20);
157 boolean send;
158 integer i;
159
159 send:=false;
160 while not send do
161 begin
162 getshare6(buf,share,1);
163 getzone6(buf,zone_ia);
164 share(1):=0;
165 share(4):=(11 shift 12)+mode;
166 share(5):=zone_ia(19)+1;
167 share(6):=share(5)+size-2;
168 share(7):=func;
169 setshare6(buf,share,1);
170 for i:=1 step 1 until 4 do
171 buf.iaf(i):=user_id(i);
172 buf.iaf(5):=password shift (-24);
173 buf.iaf(6):=password extract 24;
174 if monitor(16,buf,1,share)=0 then
175 error(2);
176 if monitor(18,buf,1,share)<>1 then
177 error(3);
178 result:=share(1);
179 if result<>8 then
180 send:=true;
181 end;
182 end;
183
183 procedure get_cat_seg(cat_type,seg_nr,status,segments);
184 <*--------------------------------------------------------------*>
185 <* Send get catalog segment message til tas *>
186 <* Message sendes via zonen buf *>
187 <* Læst segment står i buf. *>
188 <* *>
189 <* cat_type (call) : 1=user, 2=terminal, 3=type *>
190 <* seg_nr (call) : Det segment der skal læses *>
191 <* status (ret) : Status bit ved retur (ingen sat = OK) *>
192 <* segments (ret) : Antal segmenter i angivet katalog *>
193 <*--------------------------------------------------------------*>
194 integer cat_type,seg_nr,status,segments;
195 begin
196 integer array share(1:12),zone_ia(1:20);
197 boolean send;
198 integer i;
199
199 send:=false;
200 while not send do
201 begin
202 getshare6(buf,share,1);
203 getzone6(buf,zone_ia);
204 share(1):=0;
205 share(4):=(3 shift 12);
206 share(5):=zone_ia(19)+1;
207 share(6):=share(5)+510;
208 share(7):=seg_nr;
209 share(8):=cat_type;
210 setshare6(buf,share,1);
211 for i:=1 step 1 until 4 do
212 buf.iaf(i):=user_id(i);
213 buf.iaf(5):=password shift (-24);
214 buf.iaf(6):=password extract 24;
215 if monitor(16,buf,1,share)=0 then
216 error(2);
217 if monitor(18,buf,1,share)<>1 then
218 error(3);
219 status:=share(1);
220 segments:=share(4);
221 if not (false add (status shift (-23))) then
222 send:=true;
223 end;
224 end;
225
225 procedure write_field_name(key);
226 <*--------------------------------------*>
227 <* Udskriv navnet på feltet på ny linie *>
228 <*--------------------------------------*>
229 integer key;
230 begin
231 write(out,<:<10>:>);
232 write(out,true,12,case key of (
233 <:user:>,<:password:>,<:cpassword:>,<:monday:>,<:tuesday:>,
234 <:wednesday:>,<:thursday:>,<:friday:>,<:saturday:>,<:sunday:>,
235 <:sessions:>,<:privilege:>,<:mclname:>,<:base:>,<:groups:>,
236 <:mcltext:>,<:block:>,<:terminal:>,<:termtype:>,<:termgroup:>,
237 <:block:>,<:type:>,<:screentype:>,<:column:>,<:lines:>,
238 <:bypass:>,<:sbup:>,<:sbdown:>,<:sbleft:>,<:sbright:>,
239 <:sbhome:>,<:sbdelete:>,<:ceod:>,<:ceol:>,
240 <:home:>,<:left:>,<:right:>,<:up:>,<:down:>,<:xxxx:>,
241 <:xxxxx:>,<:invon:>,<:invoff:>,<:hlon:>,<:hloff:>,
242 <:delete:>,<:insert:>,<:cursor:>,<:init:>,<:freetext:>));
243 end;
244
244 procedure write_field(key,field_value,field_type);
245 <*------------------------------------------------------------------*>
246 <* Udskriv en linie indholden keyword og parrametre *>
247 <* *>
248 <* key (call) : Feltets key *>
249 <* field_value (call) : Peger til første hw i buf hvor værdier står *>
250 <* field_type (call) : Typen af værdien i feltet *>
251 <*------------------------------------------------------------------*>
252 integer key,field_value,field_type;
253 begin
254 long array field llaf;
255 integer array field liaf;
256 long field lf;
257 integer field inf;
258 boolean array field baf;
259 integer pos,i,j,ch;
260
260 case field_type of
261 begin
262 begin <* 1 *>
263 write_field_name(key);
264 llaf:=field_value-1;
265 write(out,buf.llaf);
266 end;
267 begin <* 2 *>
268 llaf:=liaf:=field_value-1;
269 if (buf.liaf(1) shift (-4))<>0 then
270 begin
271 write_field_name(key);
272 buf.liaf(11):=0;
273 write(out,buf.llaf);
274 end;
275 end;
276 begin <* 3 *>
277 baf:=field_value;
278 if buf.baf(0) then
279 write_field_name(key);
280 end;
281 begin <* 4 *>
282 lf:=field_value+3;
283 if buf.lf<>0 then
284 begin
285 write_field_name(key);
286 write(out,<<dd>,buf.lf);
287 end;
288 end;
289 begin <* 5 *>
290 write_field_name(key);
291 inf:=field_value+1;
292 write(out,<<dd>,buf.inf);
293 end;
294 begin <* 6 *>
295 baf:=field_value;
296 i:=buf.baf(0) extract 12;
297 if i<>0 then
298 begin
299 write_field_name(key);
300 write(out,<<dd>,i);
301 end;
302 end;
303 begin <* 7 *>
304 llaf:=field_value-1;
305 if get_char(buf.llaf,1,conv,ch) extract 12<>0 then
306 begin
307 write_field_name(key);
308 pos:=1;
309 repeat
310 get_char(buf.llaf,pos,conv,ch);
311 if ch<>0 then
312 write(out,<<zdd >,ch);
313 until pos>6 or ch=0;
314 end;
315 end;
316 begin <* 8 *>
317 llaf:=field_value-1;
318 if get_char(buf.llaf,1,conv,ch) extract 12<>0 then
319 begin
320 write_field_name(key);
321 pos:=1;
322 repeat
323 get_char(buf.llaf,pos,conv,ch);
324 if ch<>0 then
325 write(out,<<zdd >,ch);
326 until pos>9 or ch=0;
327 end;
328 end;
329 begin <* 9 *>
330 llaf:=field_value-1;
331 if get_char(buf.llaf,1,conv,ch) extract 12<>0 then
332 begin
333 write_field_name(key);
334 pos:=1;
335 repeat
336 get_char(buf.llaf,pos,conv,ch);
337 if ch<>0 then
338 write(out,<<zdd >,ch);
339 until pos>75 or ch=0;
340 end;
341 end;
342 begin <* 10 *>
343 baf:=field_value;
344 i:=buf.baf(0) extract 12;
345 if i<>0 then
346 begin
347 write_field_name(key);
348 for pos:=11 step (-1) until 0 do
349 begin
350 if false add (i shift (-pos)) then
351 write(out,<<dd >,11-pos);
352 end;
353 end;
354 end;
355 begin <* 11 *>
356 write_field_name(key);
357 for j:=1 step 2 until 7 do
358 begin
359 inf:=field_value+j;
360 i:=buf.inf;
361 for pos:=23 step (-1) until 0 do
362 begin
363 if false add (i shift (-pos)) then
364 write(out,<<dd >,23-pos+((j-1)*12));
365 end;
366 end;
367 end;
368 begin <* 12 *>
369 llaf:=field_value+1;
370 if buf.llaf(0) extract 12<>0 then
371 begin
372 write_field_name(key);
373 put_char(buf.llaf,(buf.llaf(0) extract 12)+1,0);
374 write(out,buf.llaf);
375 end;
376 end;
377 begin <* 13 *>
378 write_field_name(key);
379 inf:=field_value+1;
380 write(out,<<d>,buf.inf);
381 inf:=field_value+3;
382 write(out,<: :>,<<d>,buf.inf);
383 end;
384 begin <* 14 *>
385 baf:=field_value;
386 i:=buf.baf(0) extract 12;
387 if (i extract 2)<>0 then
388 begin
389 write_field_name(key);
390 write(out,<<dd >,i shift (-7),i shift (-2) extract 5);
391 end;
392 end;
393 end;
394 end;
395
395 procedure list_user;
396 <*--------------------------------------*>
397 <* Udskriv indholdet af en user indgang *>
398 <*--------------------------------------*>
399 begin
400 integer array u_id(1:4);
401 integer sep,i,result;
402
402 sep:=system(4,param,u_id.raf);
403 if sep=(8 shift 12 + 10) then
404 begin
405 param:=param+1;
406 for i:=1 step 1 until 4 do
407 buf.iaf(6+i):=u_id(i);
408 send_modify_mess(132,1,0,result);
409 if result=0 then
410 begin
411 for i:=1 step 1 until 17 do
412 write_field( case i of (
413 1,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,50),
414 case i of (
415 13,21,25,26,27,28,29,30,31,33,34,35,43,47,55,32,111),
416 case i of (
417 1,4,14,14,14,14,14,14,14,6,10,1,13,11,12,6,2));
418
418 end
419 else
420 if result<>2 then
421 begin
422 if result=4 then
423 error(4)
424 else
425 if result=13 then
426 error(5)
427 else
428 error(8);
429 end
430 else
431 begin
432 no_found:=true;
433 write(out,<:<10>; user.:>,u_id.laf,<: entry not found:>);
434 end;
435 write(out,<:<10>:>);
436 end
437 else
438 error(6);
439 end;
440
440 procedure list_term;
441 <*------------------------------------------*>
442 <* Udskriv indholdet af en terminal indgang *>
443 <*------------------------------------------*>
444 begin
445 long array t_id(1:2);
446 integer sep,i,j,ch,result;
447 long array field llaf;
448
448 llaf:=12;
449 sep:=system(4,param,t_id.raf);
450 if sep=(8 shift 12 + 10) then
451 begin
452 param:=param+1;
453 j:=i:=1;
454 get_char(t_id,i,conv,ch);
455 if ch='t' then
456 get_char(t_id,i,conv,ch);
457 buf.llaf(2):=0;
458 while i<13 do
459 begin
460 put_char(buf.llaf,j,conv,ch);
461 get_char(t_id,i,conv,ch);
462 end;
463 send_modify_mess(46,2,0,result);
464 if result=0 then
465 begin
466 for i:=1 step 1 until 6 do
467 write_field( case i of (18,19,20,26,21,50),
468 case i of (13,21,24,23,22,25),
469 case i of (1,6,6,3,6,2));
470 end
471 else
472 if result<>2 then
473 begin
474 if result=4 then
475 error(4)
476 else
477 if result=13 then
478 error(5)
479 else
480 error(9);
481 end
482 else
483 begin
484 no_found:=true;
485 write(out,<:<10>; terminal.:>,buf.llaf,<: entry not found:>);
486 end;
487 write(out,<:<10>:>);
488 end
489 else
490 error(6);
491 end;
492
492 procedure list_type;
493 <*--------------------------------------*>
494 <* Udskriv indholdet af en user indgang *>
495 <*--------------------------------------*>
496 begin
497 real array type(1:2);
498 integer sep,i,result;
499
499 sep:=system(4,param,type);
500 if sep=(8 shift 12 + 4) then
501 begin
502 param:=param+1;
503 buf.iaf(7):=type(1);
504 send_modify_mess(140,3,0,result);
505 if result=0 then
506 begin
507 for i:=1 step 1 until 26 do
508 write_field( case i of (
509 22,23,24,25,27,28,29,30,31,32,33,34,35,36,37,38,39,
510 42,43,44,45,46,47,48,49,50),
511 case i of (
512 13,15,17,18,19,20,21,22,23,24,25,29,67,65,66,63,64,
513 33,37,41,45,49,53,57,69,119),
514 case i of (
515 5,10,6,6,6,6,6,6,6,6,7,7,6,6,6,6,6,7,7,7,7,7,7,8,
516 9,2));
517 end
518 else
519 if result<>2 then
520 begin
521 if result=4 then
522 error(4)
523 else
524 if result=13 then
525 error(5)
526 else
527 error(5);
528 end
529 else
530 begin
531 no_found:=true;
532 write(out,<:<10>; type.:>,<<d>,entier type(1),<: entry not found:>);
533 end;
534 write(out,<:<10>:>);
535 end
536 else
537 error(6);
538 end;
539
539 procedure list_size;
540 <*-------------------------------------------------*>
541 <* Udskriv antallet af indgange i de tre kataloger *>
542 <*-------------------------------------------------*>
543 begin
544 integer user_ent,term_ent,type_ent,status;
545
545 get_cat_seg(1,0,status,user_size);
546 if status<>0 then
547 begin
548 if false add (status shift (-11)) then
549 error(4)
550 else
551 if false add (status shift (-10)) then
552 error(5)
553 else
554 error(11);
555 end;
556 user_hw:=buf.iaf(3);
557 user_ent:=(user_size-1)*(512//user_hw);
558 get_cat_seg(2,0,status,term_size);
559 if status<>0 then
560 begin
561 if false add (status shift (-11)) then
562 error(4)
563 else
564 if false add (status shift (-10)) then
565 error(5)
566 else
567 error(12);
568 end;
569 term_hw:=buf.iaf(3);
570 term_ent:=(term_size-1)*(512//term_hw);
571 get_cat_seg(3,0,status,type_size);
572 if status<>0 then
573 begin
574 if false add (status shift (-11)) then
575 error(4)
576 else
577 if false add (status shift (-10)) then
578 error(5)
579 else
580 error(13);
581 end;
582 type_hw:=buf.iaf(3);
583 type_ent:=(type_size-1)*(512//type_hw);
584 write(out,<:; Catalog generated at: :>);
585 outdate(out,entier systime(6,buf.iaf(4),0.0));
586 write(out,<:<10>size :>,<<d>,
587 user_ent,<:,:>,term_ent,<:,:>,type_ent);
588 write(out,<: ; Max. entries (User,Terminal,Terminaltype)<10>:>);
589 end;
590
590 procedure list_all;
591 <*-----------------------------------------*>
592 <* Udskriv alle indgange i de 3 kataloger *>
593 <*-----------------------------------------*>
594 begin
595 integer array field base;
596 integer seg_nr,i;
597
597 list_size;
598 for seg_nr:=1 step 1 until user_size-1 do
599 begin
600 get_cat_seg(1,seg_nr,0,0);
601 for base:=4 step user_hw until ((512//user_hw)-1)*user_hw+4 do
602 begin
603 if buf.base(0)<>0 then
604 begin
605 for i:=1 step 1 until 17 do
606 write_field( case i of (
607 1,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,50),
608 base-12+(case i of (
609 13,21,25,26,27,28,29,30,31,33,34,35,43,47,55,32,111)),
610 case i of (
611 1,4,14,14,14,14,14,14,14,6,10,1,13,11,12,6,2));
612
612 write(out,<:<10>:>);
613 end;
614 end;
615 end;
616 for seg_nr:=1 step 1 until term_size-1 do
617 begin
618 get_cat_seg(2,seg_nr,0,0);
619 for base:=4 step term_hw until ((512//term_hw)-1)*term_hw+4 do
620 begin
621 if buf.base(0)<>0 then
622 begin
623 for i:=1 step 1 until 6 do
624 write_field( case i of (18,19,20,26,21,50),
625 base-12+(case i of (13,21,24,23,22,25)),
626 case i of (1,6,6,3,6,2));
627 write(out,<:<10>:>);
628 end;
629 end;
630 end;
631 for seg_nr:=1 step 1 until type_size-1 do
632 begin
633 get_cat_seg(3,seg_nr,0,0);
634 for base:=0 step type_hw until ((512//type_hw)-1)*type_hw do
635 begin
636 if buf.base(1)<>0 then
637 begin
638 for i:=1 step 1 until 26 do
639 write_field( case i of (
640 22,23,24,25,27,28,29,30,31,32,33,34,35,36,37,38,39,
641 42,43,44,45,46,47,48,49,50),
642 base-12+(case i of (
643 13,15,17,18,19,20,21,22,23,24,25,29,67,65,66,63,64,
644 33,37,41,45,49,53,57,69,119)),
645 case i of (
646 5,10,6,6,6,6,6,6,6,6,7,7,6,6,6,6,6,7,7,7,7,7,7,8,
647 9,2));
648 write(out,<:<10>:>);
649 end;
650 end;
651 end;
652 end;
653
653 procedure list;
654 <*-----------------------------------------------*>
655 <* Bestem hvilken type udskrift der skal udføres *>
656 <*-----------------------------------------------*>
657 begin
658 real array name(1:2);
659
659 param:=if file_out then
660 2
661 else
662 1;
663 while system(4,param,name)<>0 do
664 begin
665 param:=param+1;
666 if name.laf(1)= long <:user:> then
667 list_user
668 else
669 if name.laf(1)= long <:termi:> add 'n' then
670 list_term
671 else
672 if name.laf(1)= long <:type:> then
673 list_type
674 else
675 if name.laf(1)= long <:size:> then
676 list_size
677 else
678 if name.laf(1)= long <:all:> then
679 list_all
680 else
681 error(6);
682 end;
683 end;
684
684 <* Hoved program *>
685 trap(alarm);
686 trapmode:=1 shift 10;
687 raf:=laf:=iaf:=baf:=0;
688 no_found:=false;
689 for i:=0 step 1 until 255 do
690 conv(i):=i;
691 set_output;
692 get_userid;
693 set_buf_zone;
694 list;
695 if file_out and no_found then
696 error(7);
697 alarm:
698 close_output;
699 stop:
700 end;\f
algol end 73
*o c
▶EOF◀