PACKET spool manager DEFINES (* Autor : R. Ruland *)
(* Stand : 23.02.88 *)
spool manager ,
server channel ,
spool duty,
station only,
auto stop,
enter spool control password,
spool control password,
start spool,
stop spool,
halt spool,
kill spool,
first spool,
spool entry line,
number spool entries,
spool status,
server task,
clear spool,
list spool,
:
LET que size = 200 ,
ack = 0 ,
nak = 1 ,
error nak = 2 ,
second phase ack = 5 ,
false code = 6 ,
fetch code = 11 ,
save code = 12 ,
exists code = 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 ,
help code = 49 ,
continue code = 100 ,
control codes = ""23""24""25""26""27""28""29"" ,
file type = 1003 ,
help file name = "help";
LET begin char = ""0"",
end char = ""1"";
LET PARAMS = STRUCT (TEXT name, userid, password, sendername, INT station);
BOUND ROW que size STRUCT (PARAMS ds params, TEXT entry line) VAR que;
ROW que size DATASPACE VAR que space;
PARAMS VAR save params;
DATASPACE VAR que ds, global ds;
FILE VAR file;
INT VAR last order, reply, old heap size, que index, fetch index,
station by start, begin pos, end pos, order task station, sp channel;
TEXT VAR que entries, free entries, order task name, buffer, deactive message,
error message buffer, sp duty, start time, control password;
BOOL VAR server is waiting, stop cmd pending, start cmd pending,
auto stop pending, stat only;
TASK VAR last order task, server, calling parent, task in control;
INITFLAG VAR in this task := FALSE, init que space := FALSE;
BOUND STRUCT (TEXT name, userid, password) VAR msg;
BOUND STRUCT (TEXT entry line, INT index, TEXT actual entries, password) VAR control msg;
BOUND PARAMS VAR fetch msg;
BOUND THESAURUS VAR all msg;
BOUND TEXT VAR error msg;
. que is empty : que entries = ""
. que is full : free entries = ""
. number entries : LENGTH que entries
. first index : code (que entries SUB 1)
. list index : code (que entries SUB que index)
. last index : code (que entries SUB number entries)
. fetch entry : que (fetch index)
. list entry : que (list index)
. last entry : que (last index)
. was define station : station by start <> station (myself)
. is valid fetch entry : fetch index > 0
.;
INT VAR command index , params ;
TEXT VAR param 1, param 2 ;
LET spool command list = "start:1.01stop:3.0halt:4.0first:5.0killer:6.0";
sp channel := 0;
sp duty := "";
deactive message := "";
stat only := FALSE;
auto stop pending := FALSE;
task in control := supervisor;
control password := "-";
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 auto stop (BOOL CONST flag) :
auto stop pending := flag
END PROC auto stop;
BOOL PROC auto stop : auto stop pending END PROC auto stop;
PROC spool duty (TEXT CONST duty) :
sp duty := duty;
END PROC spool duty;
TEXT PROC spool duty : sp duty END PROC spool duty;
PROC enter spool control password (TEXT CONST new password):
disable stop;
cover tracks;
cover tracks (control password);
control password := new password;
END PROC enter spool control password;
PROC spool control password (TEXT CONST new password):
IF on line THEN say (""3""13""5"") FI;
enter spool control password (new password);
END PROC spool control password;
PROC spool manager (PROC server start) :
spool manager (PROC (DATASPACE VAR, INT CONST,
INT CONST, TASK CONST) spool manager,
PROC server start, TRUE)
END PROC spool manager;
PROC spool manager (PROC server start, BOOL CONST initial start) :
spool manager (PROC (DATASPACE VAR, INT CONST,
INT CONST, TASK CONST) spool manager,
PROC server start, initial start)
END PROC spool manager;
PROC spool manager (PROC (DATASPACE VAR, INT CONST,
INT CONST, TASK CONST) spool,
PROC server start,
BOOL CONST initial start) :
set autonom;
break;
disable stop;
command dialogue (FALSE);
initialize spool manager;
REP start spool if necessary;
wait for next order;
IF order not allowed THEN reject order
ELIF is first phase THEN first phase
ELIF is second phase THEN second phase
ELSE send nak
FI;
send error if necessary;
collect heap garbage if necessary;
PER
. initialize spool manager :
initialize if necessary;
stop server;
erase fetch entry;
start cmd pending := initial start;
stop cmd pending := FALSE;
last order task := niltask;
. initialize if necessary :
IF NOT initialized (in this task)
THEN clear spool;
global ds := nilspace;
que ds := nilspace;
que := que ds;
server := niltask;
calling parent := niltask;
server is waiting := FALSE;
station by start := station (myself);
old heap size := 0;
error message buffer := "";
FI;
. start spool if necessary :
IF start cmd pending AND NOT stop cmd pending
THEN start server (PROC server start) FI;
. wait for next order :
INT VAR order, phase;
TASK VAR order task;
forget (global ds);
wait (global ds, order, order task);
. order not allowed :
station only CAND station (ordertask) <> station (myself) CAND
( order > 255 COR pos (control codes, code (order)) = 0 )
. reject order :
errorstop ("kein Zugriffsrecht auf Task " + text (station(myself))
+ "/""" + name(myself) + """")
. is first phase :
order <> second phase ack
. first phase :
phase := 1;
last order := order;
last order task := order task;
spool (global ds, order, phase, order task);
. is second phase :
order task = last order task
. second phase :
phase INCR 1 ;
order := last order;
spool (global ds, order, phase, order task);
. send nak :
forget (global ds);
global ds := nilspace;
send (order task, nak, global ds);
. send error if necessary :
IF is error
THEN forget (global ds);
global ds := nilspace;
error msg := global ds;
CONCR (error msg) := error message;
clear error;
send (order task, error nak, global 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 manager (DATASPACE VAR order ds,
INT CONST order, phase,
TASK CONST order task ):
enable stop;
SELECT order OF
CASE fetch code, help code : out of que or help
CASE param fetch code : send fetch params
CASE save code : new que entry
CASE file save code : new file que entry
CASE exists code : exists que entry
CASE erase code : erase que entry
CASE list code : send spool list
CASE all code : send owners ds names
CASE entry line code : send next entry line
CASE killer code : kill entry
CASE first code : make to first
CASE start code : start server task
CASE stop code : stop server task
CASE halt code, wait for halt code
: halt server task
OTHERWISE :
IF order >= continue code AND order task = supervisor
THEN spool monitor
ELSE wrong operation
FI;
END SELECT;
. wrong operation :
IF order > error nak
THEN errorstop ("falscher Auftrag fuer Task " + text (station(myself))
+ "/""" + name(myself) + """")
FI;
.
out of que or help :
IF order task = server
THEN out of que
ELSE send help file
FI;
. out of que :
erase fetch entry;
IF stop cmd pending
THEN stop server
ELIF que is empty
THEN IF auto stop pending
THEN stop server
ELSE server is waiting := TRUE
FI;
ELSE send first entry;
FI;
. send help file :
check server (TRUE);
IF order = fetch code
THEN msg := order ds;
IF msg. name <> help file name
THEN errorstop ("keine Servertask") FI;
FI;
forget (order ds);
order ds := old (help file name);
send (order task, ack, order ds);
.
send fetch params :
IF order task = server
THEN send params
ELSE errorstop ("keine Servertask")
FI;
. send params :
forget(order ds); order ds := nilspace;
fetch msg := order ds;
fetch msg := fetch entry. ds params;
send (order task, ack, order ds);
.
new que entry :
IF phase = 1
THEN prepare into que
ELSE into que (order ds, order task)
FI;
.
prepare into que :
msg := order 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 (order ds); order ds := nilspace;
send (order task, second phase ack, order ds);
.
new file que entry :
IF type (order ds) <> file type
THEN errorstop ("Datenraum hat falschen Typ");
ELSE get file params;
into que (order ds, order task);
FI;
. get file params :
file := sequential file (input, order ds);
end pos := 0;
next headline information (save params. name);
next headline information (save params. userid);
next headline information (save params. password);
next headline information (save params. sendername);
next headline information (buffer);
save params. station := int (buffer);
IF NOT last conversion ok
THEN save params. station := station (order task) FI;
IF save params. sendername = ""
THEN save params. sendername := name (order task) FI;
IF save params. name = ""
THEN IF headline (file) <> ""
THEN save params. name := headline (file);
ELSE errorstop ("Name unzulaessig")
FI;
ELSE headline (file, save params. name);
FI;
.
exists que entry :
msg := order ds ;
order task name := name (order task);
order task station := station (order task);
FOR que index FROM 1 UPTO number entries
REP IF is entry from order task (msg. name)
THEN send ack;
LEAVE exists que entry
FI;
PER ;
forget (order ds); order ds := nilspace;
send (order task, false code, order ds)
.
erase que entry :
msg := order 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 :
FOR que index FROM 1 UPTO number entries
REP IF is entry from order task (msg. name)
THEN manager question ("""" + msg.name + """ loeschen", order task);
LEAVE erase que entry
FI;
PER ;
manager message ("""" + msg.name + """ existiert nicht", order task);
. erase entry from order task :
IF is valid que index (que index) CAND is entry from order task (msg. name)
THEN delete que entry;
LEAVE erase que entry
ELSE FOR que index FROM 1 UPTO number entries
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", order task);
FI;
. delete que entry :
kill spool (que index);
send ack;
.
send owners ds names:
order task name := name (order task);
order task station := station (order task);
forget (order ds); order ds := nilspace; all msg := order ds;
all msg := empty thesaurus;
FOR que index FROM 1 UPTO number entries
REP IF is entry from order task ("")
THEN insert (all msg, list entry. ds params. name)
FI;
PER;
send (order task, ack, order ds)
.
send spool list :
forget (global ds); global ds := nilspace;
file := sequential file (output, global ds);
list spool (file);
send (order task, ack, global ds);
.
send next entry line :
control msg := order ds; check control password (control msg. password);
IF control msg. index = 0 THEN control msg. actual entries := que entries FI;
get next entry line;
send (order task, ack, order ds);
. get next entry line :
REP control msg. index INCR 1;
IF control msg. index > LENGTH control msg. actual entries
THEN control msg. index := 0;
control msg. entry line := "";
LEAVE get next entry line;
FI;
que index := control que index;
UNTIL is valid que index (que index) PER;
control msg. entry line := list entry. entry line;
. control que index :
pos (que entries, control msg. actual entries SUB control msg. index)
.
kill entry :
control msg := order ds; check control password (control msg. password);
kill spool (control que index);
send (order task, ack, order ds);
.
make to first :
control msg := order ds; check control password (control msg. password);
first spool (control que index);
send (order task, ack, order ds);
.
start server task :
msg := order ds; check control password (msg. password);
IF exists (server) AND NOT stop cmd pending
THEN errorstop ("Spool muß zuerst gestoppt werden") FI;
new server channel is necessary;
start cmd pending := TRUE;
IF server channel <= 0 OR server channel >= 33
THEN manager message ("WARNUNG : Serverkanal nicht eingestellt", order task);
ELSE send ack
FI;
. new server channel is necessary :
INT CONST new channel := int (msg. name);
IF last conversion ok THEN server channel (new channel) FI;
.
stop server task :
msg := order ds; check control password (msg. password);
IF phase = 1
THEN start cmd pending := FALSE;
deactive message := msg. name;
stop server;
check fetch entry;
ELSE reinsert fetch entry;
send ack;
FI;
.
halt server task :
msg := order ds; check control password (msg. password);
IF phase = 1
THEN stop cmd pending := TRUE;
start cmd pending := FALSE;
deactive message := msg. name;
IF NOT exists (server) OR server is waiting
THEN stop server;
check fetch entry;
ELIF order = wait for halt code
THEN calling parent := order task;
ELSE send ack;
FI;
ELSE reinsert fetch entry;
send ack;
FI;
. check fetch entry :
IF is valid fetch entry
THEN manager question (""13""10"" +
fetch entry. entry line + " neu eintragen", order task);
fetch index := -fetch index;
ELSE send ack;
FI;
.
send ack :
forget (order ds); order ds := nilspace;
send (order task, ack, order ds)
.
spool monitor :
continue (order - continue code);
disable stop;
put error message if there is one;
WHILE online
REP command dialogue (TRUE);
sysout ("");
sysin ("");
get command ("gib Spool-Kommando:");
analyze command (spool command list, 3, command index, params, param1, param2);
reset editor;
SELECT command index OF
CASE 1 : start spool
CASE 2 : start spool (int (param1))
CASE 3 : stop spool
CASE 4 : halt spool
CASE 5 : first spool
CASE 6 : kill spool
OTHERWISE : do command
END SELECT;
PER;
save error message if there is one;
command dialogue (FALSE);
break (quiet);
set autonom;
. put error message if there is one :
IF error message buffer <> ""
THEN errorstop (error message buffer); FI;
. save error message if there is one :
IF is error
THEN error message buffer := error message;
clear error;
ELSE error message buffer := "";
FI;
. reset editor :
WHILE aktueller editor > 0 REP quit PER;
clear error;
END PROC spool manager;
PROC send first entry :
forget (global ds);
global ds := que space (first index);
send (server, ack, global ds, reply) ;
IF reply = ack
THEN fetch index := first index;
que entries := subtext (que entries, 2);
server is waiting := FALSE;
start time := time of day;
start time CAT " am ";
start time CAT date;
FI;
END PROC send first entry;
PROC into que (DATASPACE VAR order ds, TASK CONST order task) :
IF que is full
THEN errorstop ("Spool ist voll")
ELSE make new entry;
send ack;
awake server if necessary
FI;
. make new entry :
que entries CAT (free entries SUB 1);
free entries := subtext (free entries, 2);
que space (last index) := order ds;
last entry. ds params := save params;
build entry line;
. 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 := entry station text;
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 (order ds));
last entry. entry line CAT " K)";
. entry station text :
IF last entry. ds params. station = 0
THEN " "
ELSE text (last entry. ds params. station, 3)
FI
. send ack :
forget (order ds); order ds := nilspace;
send (order task, ack, order ds)
. awake server if necessary :
IF server is waiting THEN send first entry FI;
END PROC into que;
(*********************************************************************)
(* Hilfsprozeduren zum Spoolmanager *)
(*********************************************************************)
PROC reinsert fetch entry :
IF fetch index <> 0
THEN insert char (que entries, code (abs (fetch index)), 1);
fetch index := 0;
FI;
END PROC reinsert fetch entry;
PROC erase fetch entry :
IF fetch index <> 0
THEN free entries CAT code (abs (fetch index));
forget (que space (abs (fetch index)));
fetch index := 0;
FI;
END PROC erase fetch entry;
PROC start server (PROC server start):
stop server;
begin (PROC server start, server);
station by start := station (myself);
start cmd pending := FALSE;
deactive message := "";
END PROC start server;
PROC stop server :
IF exists (server) THEN end (server) ELSE check server (FALSE) FI;
server := niltask;
server is waiting := FALSE;
stop cmd pending := FALSE;
send calling parent reply if necessary;
. send calling parent reply if necessary :
IF exists (calling parent)
THEN forget (global ds); global ds := nilspace;
send (calling parent, ack, global ds);
calling parent := niltask;
FI;
END PROC stop server;
PROC check server (BOOL CONST with stop) :
IF was define station CAND NOT is niltask (server)
THEN stop old server if necessary FI;
. stop old server if necessary :
access catalogue;
TASK VAR old server := son (myself);
WHILE NOT is niltask (old server)
REP IF index (old server) = index (server) THEN old server found FI;
old server := brother (old server);
PER;
. old server found :
IF name (old server) = "-" THEN end (old server) FI;
IF with stop THEN stop server FI;
LEAVE stop old server if necessary;
END PROC check server;
BOOL PROC is valid que index (INT CONST index) :
1 <= index AND index <= number entries
END PROC is valid que index;
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 check control password (TEXT CONST password) :
IF control password = "-"
THEN errorstop ("Kontrolle des Spools nicht erlaubt")
ELIF control password <> "" CAND control password <> password
THEN errorstop ("Passwort falsch")
FI;
END PROC check control password;
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;
(*********************************************************************)
(* Prozeduren zur Verwaltung der Warteschlange *)
(*********************************************************************)
PROC start spool :
enable stop;
IF server channel <= 0 OR server channel >= 33
THEN display (""13""10"WARNUNG : Serverkanal nicht eingestellt"13""10"")
FI;
halt spool;
start cmd pending := TRUE;
END PROC start spool;
PROC start spool (INT CONST new channel) :
enable stop;
server channel (new channel);
start spool;
END PROC start spool;
PROC stop spool (TEXT CONST deactive msg) :
disable stop;
deactive message := deactive msg;
start cmd pending := FALSE;
stop server;
IF is valid fetch entry CAND on line CAND
yes (""13""10"" + fetch entry. entry line + " neu eintragen")
THEN reinsert fetch entry
ELSE erase fetch entry;
FI;
END PROC stop spool;
PROC stop spool : stop spool ("") END PROC stop spool;
PROC halt spool (TEXT CONST deactive msg) :
enable stop;
deactive message := deactive msg;
stop cmd pending := TRUE;
start cmd pending := FALSE;
IF NOT exists (server) OR server is waiting THEN stop spool FI;
END PROC halt spool;
PROC halt spool : halt spool ("") END PROC halt spool;
PROC kill spool :
enable stop;
say (""13""10"");
que index := 1;
WHILE que index <= number entries
REP IF yes (list entry. entry line + " loeschen")
THEN kill spool (que index)
ELSE que index INCR 1
FI;
PER;
END PROC kill spool;
PROC kill spool (INT CONST index) :
IF is valid que index (index)
THEN forget (que space (code (que entries SUB index)));
free entries CAT (que entries SUB index);
delete char (que entries, index);
FI;
END PROC kill spool;
PROC first spool :
enable stop;
say (""13""10"");
FOR que index FROM 1 UPTO number entries
REP IF yes (list entry. entry line + " als erstes")
THEN first spool (que index);
LEAVE first spool
FI;
PER;
END PROC first spool;
PROC first spool (INT CONST index) :
IF is valid que index (index)
THEN insert char (que entries, que entries SUB index, 1);
delete char (que entries, index + 1);
FI;
END PROC first spool;
TEXT PROC spool entry line (INT CONST index) :
IF index = 0 CAND is valid fetch entry
THEN fetch entry. entry line
ELIF is valid que index (index)
THEN entry. entry line
ELSE ""
FI
. entry : que (code (que entries SUB index))
END PROC spool entry line;
INT PROC number spool entries : number entries END PROC number spool entries;
INT PROC spool status :
IF exists (server)
THEN IF stop cmd pending
THEN IF start cmd pending
THEN 3 (* aktiviert (neu start) *)
ELSE 2 (* aktiviert (warten auf halt) *)
FI
ELSE IF server is waiting
THEN 0 (* kein Auftrag in Bearbeitung *)
ELSE 1 (* aktiviert *)
FI
FI
ELIF start cmd pending
THEN 0 (* wird aktiviert *)
ELIF is valid fetch entry
THEN IF was define station
THEN -3 (* deaktiviert (define station) *)
ELSE -2 (* deaktiviert (server gelöcht) *)
FI
ELSE -1 (* deaktiviert *)
FI
END PROC spool status;
TASK PROC server task : server END PROC server task;
PROC clear spool :
disable stop;
IF NOT initialized (init que space)
THEN FOR que index FROM 1 UPTO que size
REP que space (que index) := nilspace PER;
FI;
que entries := "";
free entries := "";
fetch index := 0;
stop server;
FOR que index FROM 1 UPTO que size
REP forget (que space (que index));
free entries CAT code (que index);
PER;
END PROC clear spool;
PROC list spool :
disable stop;
DATASPACE VAR list ds := nilspace;
FILE VAR list file := sequential file (output, list ds);
list spool (list file);
show (list file);
forget (list ds);
END PROC list spool;
PROC list spool (FILE VAR f) :
enable stop;
output (f);
max line length (f, 1000);
headline (f, station text + name (myself) + """");
put spool duty;
put current job;
put spool que;
. station text :
IF station(myself) = 0
THEN "/"""
ELSE text (station(myself)) + "/"""
FI
. put spool duty :
IF spool duty <> ""
THEN write (f, "Aufgabe: ");
write (f, spool duty );
line (f, 2);
FI;
. put current job :
IF is valid fetch entry
THEN write (f, "In Bearbeitung seit ");
write (f, start time);
write (f, ":");
line (f, 2);
putline (f, fetch entry. entry line);
IF NOT exists (server)
THEN IF was define station
THEN putline (f, "Spool ist deaktiviert, da Stationsnummer geaendert wurde")
ELSE putline (f, "Spool ist deaktiviert, da der Server gelöscht wurde")
FI;
ELIF stop cmd pending
THEN IF start cmd pending
THEN putline (f, "Spool wird nach diesem Auftrag neu aktiviert");
ELSE putline (f, "Spool wird nach diesem Auftrag deaktiviert");
FI;
FI;
line (f);
ELSE write (f, "kein Auftrag in Bearbeitung");
IF NOT exists (server)
THEN write (f, ", da Spool deaktiviert");
IF start cmd pending
THEN line (f);
write (f, "Spool wird nach Verlassen der Task aktiviert");
FI;
IF deactive message <> ""
THEN line (f);
write (f, deactive message);
FI;
ELIF que is empty
THEN write (f, ", da Warteschlange leer");
LEAVE list spool;
FI;
line (f, 2);
FI;
. put spool que :
IF que is empty
THEN putline (f, "Warteschlange ist leer");
ELSE write (f, "Warteschlange (");
write (f, text (number entries));
IF number entries = 1
THEN write (f, " Auftrag):");
ELSE write (f, " Auftraege):");
FI;
line (f, 2);
FOR que index FROM 1 UPTO number entries
REP putline (f, list entry. entry line) PER;
FI;
END PROC list spool;
ENDPACKET spool manager;