From 71e2b36ccd05ea678e62e32ee6245df2b8d6ac17 Mon Sep 17 00:00:00 2001
From: Lars-Dominik Braun <lars@6xq.net>
Date: Thu, 7 Feb 2019 10:05:49 +0100
Subject: Move spooler into its own package
I *think* these parts belong together.
---
system/multiuser/1.7.5/src/spool manager | 887 -------------------------------
1 file changed, 887 deletions(-)
delete mode 100644 system/multiuser/1.7.5/src/spool manager
(limited to 'system/multiuser')
diff --git a/system/multiuser/1.7.5/src/spool manager b/system/multiuser/1.7.5/src/spool manager
deleted file mode 100644
index ac0295a..0000000
--- a/system/multiuser/1.7.5/src/spool manager
+++ /dev/null
@@ -1,887 +0,0 @@
-PACKET spool manager DEFINES (* Autor: J. Liedtke *)
- (* R. Nolting *)
- (* R. Ruland *)
- (* Stand: 25.04.86 *)
-
- spool manager ,
-
- server channel ,
- spool duty,
- station only,
- spool control task :
-
-LET que size = 101 ,
-
- ack = 0 ,
- nak = 1 ,
- error nak = 2 ,
- message ack = 3 ,
- question ack = 4 ,
- second phase ack = 5 ,
-
- fetch code = 11 ,
- save code = 12 ,
- file save code old = 13 ,
- erase code = 14 ,
- list code = 15 ,
- all code = 17 ,
- param fetch code = 21 ,
- file save code = 22 ,
- entry line code = 23 ,
- killer code = 24 ,
- first code = 25 ,
- start code = 26 ,
- stop code = 27 ,
- halt code = 28 ,
- wait for halt code = 29 ,
-
- continue code = 100 ,
-
- file type = 1003 ;
-
-LET begin char = ""0"",
- end char = ""1"";
-
-LET PARAMS = STRUCT (TEXT name, userid, password, sendername, INT station),
- ENTRY = STRUCT (PARAMS ds params, TEXT entry line, DATASPACE space);
-
-ROW que size ENTRY VAR que ;
-
-PARAMS CONST empty params := PARAMS : ("", "", "", "", -1);
-
-PARAMS VAR save params, file save params;
-
-ENTRY VAR fetch entry;
-
-FILE VAR file;
-
-INT VAR order, last order, phase, reply, old heap size, first, last, list index,
- begin pos, end pos, order task station, sp channel, counter;
-
-TEXT VAR order task name, buffer, sp duty, start time;
-
-BOOL VAR server is waiting, stop command pending, stat only, valid fetch entry;
-
-TASK VAR order task, last order task, server, calling parent, task in control;
-
-INITFLAG VAR in this task := FALSE;
-
-DATASPACE VAR ds;
-
-BOUND STRUCT (TEXT name, userid, password) VAR msg;
-BOUND STRUCT (TEXT entry line, INT index) VAR control msg;
-BOUND PARAMS VAR fetch msg;
-BOUND THESAURUS VAR all msg;
-BOUND TEXT VAR error msg ;
-
-
-. first entry : que (first)
-. list entry : que (list index)
-. last entry : que (last)
-
-. que is empty : first = last
-. que is full : first = next (last)
-.;
-
-sp channel := 0;
-sp duty := "";
-stat only := FALSE;
-task in control := myself;
-
-PROC server channel (INT CONST channel nr) :
- IF channel nr <= 0 OR channel nr >= 33
- THEN errorstop ("falsche Kanalangabe") FI;
- sp channel := channel nr;
-END PROC server channel;
-
-INT PROC server channel :
- sp channel
-END PROC server channel;
-
-
-PROC station only (BOOL CONST flag) :
- stat only := flag
-END PROC station only;
-
-BOOL PROC station only :
- stat only
-END PROC station only;
-
-
-PROC spool duty (TEXT CONST duty) :
- sp duty := duty;
-END PROC spool duty;
-
-TEXT PROC spool duty :
- sp duty
-END PROC spool duty;
-
-
-PROC spool control task (TASK CONST task id):
- task in control := task id;
-END PROC spool control task;
-
-TASK PROC spool control task :
- task in control
-END PROC spool control task;
-
-
-PROC spool manager (PROC server start) :
-
- spool manager (PROC server start, TRUE)
-
-END PROC spool manager;
-
-
-PROC spool manager (PROC server start, BOOL CONST with start) :
-
- set autonom ;
- break ;
- disable stop ;
- initialize spool manager ;
- REP forget (ds) ;
- wait (ds, order, order task) ;
- IF order <> second phase ack
- THEN prepare first phase ;
- spool (PROC server start);
- ELIF order task = last order task
- THEN prepare second phase ;
- spool (PROC server start);
- ELSE send nak
- FI ;
- send error if necessary ;
- collect heap garbage if necessary
- PER
-
- . initialize spool manager :
- initialize if necessary;
- stop;
- erase fetch entry;
- IF with start THEN start (PROC server start) FI;
-
- . initialize if necessary :
- IF NOT initialized (in this task)
- THEN FOR list index FROM 1 UPTO que size
- REP list entry. space := nilspace PER;
- fetch entry. space := nilspace;
- ds := nilspace;
- last order task := niltask;
- server := niltask;
- calling parent := niltask;
- server is waiting := FALSE;
- stop command pending := FALSE;
- old heap size := 0;
- clear spool;
- FI;
-
- . prepare first phase :
- IF order = save code OR order = erase code OR order = stop code
- THEN phase := 1 ;
- last order := order ;
- last order task := order task ;
- FI;
-
- . prepare second phase :
- phase INCR 1 ;
- order := last order
-
- . send nak :
- forget (ds) ;
- ds := nilspace ;
- send (order task, nak, ds);
-
- . send error if necessary :
- IF is error
- THEN forget (ds) ;
- ds := nilspace ;
- error msg := ds ;
- CONCR (error msg) := error message;
- clear error;
- send (order task, error nak, ds)
- FI;
-
- . collect heap garbage if necessary :
- IF heap size > old heap size + 2
- THEN collect heap garbage;
- old heap size := heap size;
- FI;
-
-END PROC spool manager;
-
-
-PROC spool (PROC server start):
-
- command dialogue (FALSE);
- enable stop;
- IF station only CAND station (ordertask) <> station (myself)
- THEN errorstop ("kein Zugriffsrecht auf Task " + text (station(myself))
- + "/""" + name(myself) + """")
- FI;
-
- SELECT order OF
-
- CASE fetch code : out of que
- CASE param fetch code : send fetch params
- CASE save code : new que entry
- CASE file save code, file save code old :
- new file que entry
- CASE erase code : erase que entry
- CASE list code : send spool list
- CASE all code : send owners ds names
-
- OTHERWISE :
-
- IF order >= continue code AND order task = supervisor
- THEN forget (ds);
- spool command (PROC server start)
-
- ELIF spool control allowed by order task
- THEN SELECT order OF
- CASE entry line code : send next entry line
- CASE killer code : kill entry
- CASE first code : make to first
- CASE start code : start server
- CASE stop code : stop server
- CASE halt code : halt server
- CASE wait for halt code : wait for halt
- OTHERWISE : errorstop ("falscher Auftrag fuer Task """
- + name(myself) + """")
- END SELECT
-
- ELSE errorstop ("falscher Auftrag fuer Task """
- + name(myself) + """")
- FI;
- END SELECT;
-
-
-. spool control allowed by order task :
- (order task = spool control task OR order task < spool control task
- OR spool control task = supervisor)
- AND station (order task) = station (myself)
-.
- out of que :
- IF NOT (order task = server)
- THEN errorstop ("keine Servertask")
- ELIF stop command pending
- THEN forget (ds);
- stop;
- erase fetch entry;
- ELIF que is empty
- THEN forget (ds) ;
- erase fetch entry;
- server is waiting := TRUE;
- ELSE send first entry;
- FI;
-
-.
- send fetch params :
- IF order task = server
- THEN send params
- ELSE errorstop ("keine Servertask")
- FI;
-
- . send params :
- forget(ds); ds := nilspace; fetch msg := ds;
- fetch msg := fetch entry. ds params;
- send (order task, ack, ds);
-
-.
- new que entry :
- IF phase = 1
- THEN prepare into que
- ELSE into que
- FI;
-
-.
- prepare into que :
- msg := ds ;
- save params. name := msg.name;
- save params. userid := msg.userid;
- save params. password := msg.password;
- save params. sendername := name (order task);
- save params. station := station (order task);
- forget (ds); ds := nilspace;
- send (order task, second phase ack, ds);
-
-.
- new file que entry :
- IF type (ds) <> file type
- THEN errorstop ("Datenraum hat falschen Typ");
- ELSE get file params;
- into que;
- FI;
-
- . get file params :
- file := sequential file (input, ds);
- end pos := 0;
- next headline information (file save params. name);
- next headline information (file save params. userid);
- next headline information (file save params. password);
- next headline information (file save params. sendername);
- next headline information (buffer);
- file save params. station := int (buffer);
- IF NOT last conversion ok
- THEN file save params. station := station (order task) FI;
- IF file save params. sendername = ""
- THEN file save params. sendername := name (order task) FI;
- IF file save params. name = ""
- THEN IF headline (file) <> ""
- THEN file save params. name := headline (file);
- ELSE errorstop ("Name unzulaessig")
- FI;
- ELSE headline (file, file save params. name);
- FI;
-
-.
- erase que entry :
- msg := ds ;
- order task name := name (order task);
- order task station := station (order task);
- IF phase = 1
- THEN ask for erase
- ELSE erase entry from order task
- FI;
-
- . ask for erase :
- to first que entry;
- WHILE next que entry found
- REP IF is entry from order task (msg. name)
- THEN manager question ("""" + msg.name + """ loeschen");
- LEAVE erase que entry
- FI;
- PER ;
- manager message ("""" + msg.name + """ existiert nicht");
-
- . erase entry from order task :
- IF is entry from order task (msg. name)
- THEN delete que entry;
- LEAVE erase que entry
- ELSE to first que entry;
- WHILE next que entry found
- REP IF is entry from order task (msg. name)
- THEN delete que entry;
- LEAVE erase que entry
- FI ;
- PER ;
- manager message ("""" + msg.name + """ existiert nicht");
- FI;
-
- . delete que entry :
- erase entry (list index) ;
- send ack;
-
-.
- send owners ds names:
- order task name := name (order task);
- order task station := station (order task);
- forget (ds); ds := nilspace; all msg := ds;
- all msg := empty thesaurus;
- to first que entry;
- WHILE next que entry found
- REP IF is entry from order task ("")
- THEN insert (all msg, list entry. ds params. name)
- FI;
- PER;
- send (order task, ack, ds)
-
-.
- send spool list :
- list spool;
- send (order task, ack, ds);
-
-.
- send next entry line :
- control msg := ds;
- get next entry line (control msg. entry line, control msg. index);
- send (order task, ack, ds);
-
-.
- kill entry :
- control msg := ds;
- list index := control msg. index;
- IF is valid que entry (list index)
- THEN erase entry (list index)
- FI;
- send (order task, ack, ds);
-
-.
- make to first :
- control msg := ds;
- list index := control msg. index;
- IF is valid que entry (list index)
- THEN new first (list entry);
- erase entry (list index);
- FI;
- send (order task, ack, ds);
-
-.
- start server :
- IF exists (server) THEN errorstop ("Spool muß zuerst gestoppt werden") FI;
- start (PROC server start);
- IF server channel <= 0 OR server channel >= 33
- THEN manager message ("WARNUNG : Serverkanal nicht eingestellt");
- ELSE send ack
- FI;
-
-.
- stop server:
- IF phase = 1
- THEN stop;
- IF valid fetch entry
- THEN valid fetch entry := FALSE;
- manager question (""13""10"" +
- fetch entry. entry line + " neu eintragen");
- ELSE erase fetch entry;
- send ack;
- FI;
- ELSE IF fetch entry. entry line <> "" THEN new first (fetch entry) FI;
- erase fetch entry;
- send ack;
- FI;
-
-.
- halt server :
- stop command pending := TRUE;
- IF NOT exists (server) OR server is waiting
- THEN stop;
- erase fetch entry;
- FI;
- send ack;
-
-.
- wait for halt :
- IF exists (calling parent)
- THEN errorstop ("Task """ + name (calling parent) + """ wartet schon auf halt")
- ELSE calling parent := order task;
- stop command pending := TRUE;
- forget (ds);
- IF NOT exists (server) OR server is waiting
- THEN stop;
- erase fetch entry;
- FI;
- FI;
-
-END PROC spool;
-
-
-PROC send first entry :
-
- forget (ds); ds := first entry. space;
- send (server, ack, ds, reply) ;
- IF reply = ack
- THEN server is waiting := FALSE;
- start time := time of day;
- start time CAT " am ";
- start time CAT date;
- erase fetch entry;
- fetch entry := first entry;
- erase entry (first);
- valid fetch entry := TRUE;
- ELSE forget (ds);
- FI;
-
-END PROC send first entry;
-
-
-PROC into que :
-
- IF que is full
- THEN errorstop ("Spool ist voll")
- ELSE make new entry;
- send ack;
- awake server if necessary
- FI;
-
- . make new entry :
- IF order = save code
- THEN last entry. ds params := save params;
- save params := empty params;
- ELSE last entry. ds params := file save params;
- file save params := empty params;
- FI;
- last entry. space := ds;
- counter INCR 1;
- build entry line;
- last := next (last) ;
-
- . build entry line :
- IF LENGTH last entry. ds params. sender name > 16
- THEN buffer := subtext (last entry. ds params. sender name, 1, 13);
- buffer CAT "...""";
- ELSE buffer := last entry. ds params. sender name;
- buffer CAT """";
- buffer := text (buffer, 17);
- FI;
- last entry. entry line := text (last entry. ds params. station, 2);
- last entry. entry line CAT "/""";
- last entry. entry line CAT buffer;
- last entry. entry line CAT " : """ ;
- last entry. entry line CAT last entry. ds params. name;
- last entry. entry line CAT """ (" ;
- last entry. entry line CAT text (storage (last entry. space));
- last entry. entry line CAT " K)";
-
- . awake server if necessary :
- IF server is waiting THEN send first entry FI;
-
-END PROC into que;
-
-
-PROC list spool :
-
- forget (ds); ds := nilspace;
- file := sequential file (output, ds) ;
- max line length (file, 1000);
- headline(file, text (station(myself)) + "/""" + name (myself) + """");
- put spool duty;
- put current job;
- put spool que;
-
- . put spool duty :
- IF spool duty <> ""
- THEN write (file, "Aufgabe: ");
- write (file, spool duty );
- line (file, 2);
- FI;
-
- . put current job :
- IF valid fetch entry AND exists (server)
- THEN write (file, "In Bearbeitung seit ");
- write (file, start time);
- write (file, ":");
- line (file, 2);
- putline (file, fetch entry. entry line);
- IF stop command pending
- THEN putline (file, "Spool wird nach diesem Auftrag deaktiviert");
- FI;
- line (file);
- ELSE write (file, "kein Auftrag in Bearbeitung");
- IF NOT exists (server)
- THEN write (file, ", da Spool deaktiviert");
- ELIF que is empty
- THEN write (file, ", da Warteschlange leer");
- LEAVE list spool;
- FI;
- line (file, 2);
- FI;
-
- . put spool que :
- IF que is empty
- THEN putline (file, "Warteschlange ist leer");
- ELSE write (file, "Warteschlange (");
- write (file, text (counter));
- write (file, " Auftraege):");
- line (file, 2);
- to first que entry ;
- WHILE next que entry found
- REP putline (file, list entry. entry line) PER;
- FI;
-
-END PROC list spool ;
-
-
-PROC clear spool :
-
- first := 1;
- last := 1;
- counter := 0;
- FOR list index FROM 1 UPTO que size
- REP list entry. ds params := empty params;
- list entry. entry line := "";
- forget (list entry. space)
- PER;
-
-END PROC clear spool;
-
-(*********************************************************************)
-(* Hilfsprozeduren zum Spoolmanager *)
-
-BOOL PROC is valid que entry (INT CONST index) :
-
- que (index). entry line <> ""
-
-END PROC is valid que entry;
-
-
-INT PROC next (INT CONST index) :
-
- IF index < que size
- THEN index + 1
- ELSE 1
- FI
-
-END PROC next;
-
-
-PROC to first que entry :
-
- list index := first - 1;
-
-ENDPROC to first que entry ;
-
-
-BOOL PROC next que entry found :
-
- list index := next (list index);
- WHILE is not last que entry
- REP IF is valid que entry (list index)
- THEN LEAVE next que entry found WITH TRUE FI;
- list index := next (list index);
- PER;
- FALSE
-
- . is not last que entry :
- list index <> last
-
-ENDPROC next que entry found ;
-
-
-PROC get next entry line (TEXT VAR entry line, INT VAR index) :
-
- IF index = 0
- THEN list index := first - 1
- ELSE list index := index
- FI;
- IF next que entry found
- THEN entry line := list entry. entry line;
- index := list index;
- ELSE entry line := "";
- index := 0;
- FI;
-
-END PROC get next entry line;
-
-
-PROC new first (ENTRY VAR new first entry) :
-
- IF que is full
- THEN errorstop ("Spool ist voll")
- ELSE first DECR 1 ;
- IF first = 0 THEN first := que size FI;
- first entry := new first entry;
- counter INCR 1;
- FI;
-
-END PROC new first;
-
-
-PROC erase entry (INT CONST index) :
-
- entry. ds params := empty params;
- entry. entry line := "";
- forget (entry.space) ;
- counter DECR 1;
- IF index = first
- THEN inc first
- FI ;
-
- . entry : que (index)
-
- . inc first :
- REP first := next (first)
- UNTIL que is empty OR is valid que entry (first) PER
-
-END PROC erase entry;
-
-
-PROC erase fetch entry :
-
- fetch entry. ds params := empty params;
- fetch entry. entry line := "";
- forget (fetch entry. space);
- valid fetch entry := FALSE;
-
-END PROC erase fetch entry;
-
-
-BOOL PROC is entry from order task (TEXT CONST file name) :
-
- correct order task CAND correct filename
-
- . correct order task :
- order task name = list entry. ds params. sendername
- AND order task station = list entry. ds params. station
-
- . correct file name :
- file name = "" OR file name = list entry. ds params. name
-
-END PROC is entry from order task;
-
-
-PROC start (PROC server start):
-
- begin (PROC server start, server);
-
-END PROC start;
-
-
-PROC stop :
-
- stop server;
- send calling parent reply if necessary;
-
- . stop server:
- IF exists (server) THEN end (server) FI;
- server := niltask;
- server is waiting := FALSE;
- stop command pending := FALSE;
-
- . send calling parent reply if necessary :
- IF exists (calling parent)
- THEN forget (ds); ds := nilspace;
- send (calling parent, ack, ds);
- calling parent := niltask;
- FI;
-
-END PROC stop;
-
-
-PROC next headline information (TEXT VAR t):
-
- begin pos := pos (headline (file), begin char, end pos + 1);
- IF begin pos = 0
- THEN begin pos := LENGTH headline (file) + 1;
- t := "";
- ELSE end pos := pos (headline (file), end char, begin pos + 1);
- IF end pos = 0
- THEN end pos := LENGTH headline (file) + 1;
- t := "";
- ELSE t := subtext (headline (file), begin pos+1, end pos-1)
- FI
- FI
-
-END PROC next headline information;
-
-
-PROC send ack :
-
- forget (ds); ds := nilspace;
- send (order task, ack, ds)
-
-END PROC send ack;
-
-
-PROC manager question (TEXT CONST question) :
-
- forget (ds); ds := nilspace; error msg := ds ;
- error msg := question ;
- send (order task, question ack, ds)
-
-ENDPROC manager question ;
-
-
-PROC manager message (TEXT CONST message) :
-
- forget (ds); ds := nilspace; error msg := ds ;
- error msg := message ;
- send (order task, message ack, ds)
-
-ENDPROC manager message ;
-
-(*********************************************************************)
-(* Spool - Kommandos *)
-
-INT VAR command index , params ;
-TEXT VAR command line, param 1, param 2 ;
-
-LET spool command list =
-"break:1.0start:2.01stop:4.0halt:5.0first:6.0killer:7.0listspool:8.0
-clearspool:9.0spoolcontrolby:10.1";
-
-PROC spool command (PROC server start) :
-
- enable stop ;
- continue (order - continue code) ;
- disable stop ;
- REP command dialogue (TRUE) ;
- get command ("gib Spool-Kommando:", command line);
- analyze command (spool command list, command line, 3, command index,
- params, param1, param2);
- execute command (PROC server start);
- UNTIL NOT online PER;
- command dialogue (FALSE);
- break (quiet);
- set autonom;
-
-END PROC spool command;
-
-
-PROC execute command (PROC server start) :
-
- enable stop;
- SELECT command index OF
- CASE 1 : break
- CASE 2 : start server
- CASE 3 : start server with new channel
- CASE 4 : stop server
- CASE 5 : halt server
- CASE 6 : first cmd
- CASE 7 : killer cmd
- CASE 8 : show spool list
- CASE 9 : clear spool
- CASE 10 : spool control task (task (param1))
- OTHERWISE do (command line)
- END SELECT;
-
- . start server :
- IF server channel <= 0 OR server channel >= 33
- THEN line;
- putline ("WARNUNG : Serverkanal nicht eingestellt");
- FI;
- stop server;
- start (PROC server start);
-
- . start server with new channel:
- INT VAR i := int (param1);
- IF last conversion ok
- THEN server channel (i);
- start server;
- ELSE errorstop ("falsche Kanalangabe")
- FI;
-
- . stop server :
- disable stop;
- stop;
- IF valid fetch entry CAND
- yes (""13""10"" + fetch entry. entry line + " neu eintragen")
- THEN new first (fetch entry) FI;
- erase fetch entry;
- enable stop;
-
- . halt server :
- stop command pending := TRUE;
- IF NOT exists (server) OR server is waiting
- THEN stop server;
- erase fetch entry;
- FI;
-
- . first cmd :
- line ;
- to first que entry ;
- WHILE next que entry found
- REP say (list entry. entry line) ;
- IF yes (" als erstes")
- THEN new first (list entry);
- erase entry (list index);
- LEAVE first cmd
- FI ;
- PER;
-
- . killer cmd :
- line ;
- to first que entry ;
- WHILE next que entry found
- REP say (list entry. entry line) ;
- IF yes (" loeschen") THEN erase entry (list index) FI ;
- PER;
-
- . show spool list :
- list spool;
- disable stop;
- show (file);
- forget (ds);
-
-ENDPROC execute command ;
-
-ENDPACKET spool manager;
-
--
cgit v1.2.3