|
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: 26880 (0x6900)
Types: TextFile
Names: »ltclist «
└─⟦9ccaf6601⟧ Bits:30008165 Bånd med SW8000 kildetekst/release værktøjer
└─⟦f546e193b⟧
└─⟦this⟧ »ltclist «
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 72
▶EOF◀