summaryrefslogtreecommitdiff
path: root/app/mpg/2.2/src/PUBLIC.insert
diff options
context:
space:
mode:
Diffstat (limited to 'app/mpg/2.2/src/PUBLIC.insert')
-rw-r--r--app/mpg/2.2/src/PUBLIC.insert3412
1 files changed, 3412 insertions, 0 deletions
diff --git a/app/mpg/2.2/src/PUBLIC.insert b/app/mpg/2.2/src/PUBLIC.insert
new file mode 100644
index 0000000..9fb98a6
--- /dev/null
+++ b/app/mpg/2.2/src/PUBLIC.insert
@@ -0,0 +1,3412 @@
+(* Rainer Kottmann *)
+(* Klaus Bovermann *)
+(* Lutz Prechelt *)
+(* Carsten Weinholz *)
+(* 19.06.87 *)
+
+(* Pakete : 1. mpg test elan programs
+ 2. mpg archive system <--- **************************
+ 3. mpg some <--- Sind für seperaten Hamster
+ 4. mpg dm <--- notwendig.
+ 5. mpg tools <--- **************************
+ 6. mpg target handling
+ 7. mpg print cmd
+ 8. edit monitor
+ 9. mpg global manager *)
+
+(************************* ELAN TEST ****************************)
+
+PACKET mpg test elan programs DEFINES elan test :
+
+LET scan end = 7,
+ in comment = 8,
+ in text = 9,
+ bold = 2,
+ char = 4,
+ delimiter = 6,
+ limit = 77,
+ max denoter length = 255,
+ end bolds = "ENDIFIENDSELECTENDREPEATPERENDPROCEDURENDPACKETENDOP",
+ w = "WARNING: ",
+ e = "ERROR : ";
+
+INT VAR zeile;
+FILE VAR err;
+TEXT VAR last error;
+
+
+PROC elan test :
+ elan test (last param)
+END PROC elan test;
+
+PROC elan test (TEXT CONST datei) :
+ INT VAR byte :: 0, kbyte :: 0, (* Byte/Kilobyte der EUMEL Datei *)
+ sbyte:: 0, skbyte:: 0, (* Byte/Kilobyte des Elan Quelltextes *)
+ denoter length :: 0, units :: 0, typ, scan operations :: 0,
+ round brackets :: 0, square brackets :: 0; (* Klammerzaehler *)
+ TEXT VAR in, symbol;
+ FILE VAR inputfile :: sequential file (input , datei);
+ err := note file;
+ zeile := 0;
+ last error := "";
+ scan (""); next symbol (in);
+ WHILE NOT eof (inputfile) REP
+ naechste zeile;
+ analyse;
+ in := incharety
+ UNTIL in <> "" PER;
+ IF in <> ""
+ THEN putline (err, "*** ELAN TEST VORZEITIG ABGEBROCHEN ***") FI;
+ last error := "";
+ ausgabe der enddaten;
+ modify (inputfile);
+ note edit (inputfile);
+ line.
+
+naechste zeile :
+ getline (inputfile , in);
+ continue scan (in);
+ byte INCR LENGTH in;
+ kbyte INCR byte DIV 1000;
+ byte := byte MOD 1000;
+ zeile INCR 1; cout (zeile);
+ IF LENGTH in > limit
+ THEN error (w + "line exceeding screen")
+ FI.
+
+analyse :
+ REPEAT
+ next symbol (symbol, typ);
+ scan operations INCR 1;
+ analysiere symbol
+ UNTIL typ >= scan end
+ PER;
+ IF typ = in comment
+ THEN error (w + "comment exceeding line")
+ FI;
+ IF typ = in text
+ THEN denoter length INCR LENGTH symbol;
+ IF denoter length > max denoter length
+ THEN error (e + "text denoter too long (" + text (denoter length) +
+ " characters)")
+ ELSE error (w + "text denoter exceeding source line")
+ FI
+ ELSE denoter length := 0
+ FI;
+ skbyte INCR sbyte DIV 1000;
+ sbyte := sbyte MOD 1000.
+
+analysiere symbol :
+ IF typ = scan end THEN test brackets
+ ELIF typ = delimiter THEN delimiters
+ ELIF typ = char
+ THEN denoter length INCR LENGTH symbol;
+ IF denoter length > max denoter length
+ THEN error (e + "text denoter too long (" + text (denoter length) +
+ " characters)")
+ FI
+ ELIF typ = bold CAND pos (endbolds, symbol) <> 0
+ THEN unitend
+ FI;
+ sbyte INCR LENGTH symbol.
+
+test brackets :
+ IF round brackets <> 0
+ THEN error (w + text (round brackets) + " ""("" open")
+ FI;
+ IF square brackets <> 0
+ THEN error (w + text (square brackets) + " ""["" open")
+ FI.
+
+delimiters :
+ IF symbol = ";" OR (symbol = "." AND is refinement)
+ THEN unitend
+ ELIF symbol = "(" THEN round brackets INCR 1
+ ELIF symbol = ")" THEN round brackets DECR 1
+ ELIF symbol = "[" THEN square brackets INCR 1
+ ELIF symbol = "]" THEN square brackets DECR 1
+ FI.
+
+unitend :
+ units INCR 1;
+ IF round brackets <> 0
+ THEN error (e + text (round brackets) + " ""("" open at end of unit");
+ round brackets := 0
+ FI;
+ IF square brackets <> 0
+ THEN error (e + text (square brackets) + " ""["" open at end of unit");
+ square brackets := 0
+ FI.
+
+is refinement : FALSE. (* vorlaeufig *)
+
+ausgabe der enddaten :
+ line (err);
+ putline (err, 77 * "=");
+ putline (err, "EUMEL - Datei : " + text (zeile) + " Zeilen , " +
+ bytes (kbyte, byte));
+ putline (err, "Elan - Quelltext : " + text (units) + " Units , " +
+ bytes (skbyte, sbyte));
+ putline (err, text (scan operations) +
+ " Scanner - Operationen durchgefuehrt.");
+ putline (err, 77 * "=").
+END PROC elan test;
+
+PROC error (TEXT CONST error message) :
+ IF error message = last error
+ THEN putline (err, "dito " + text (zeile));
+ IF online THEN put (zeile); putline ("dito") FI;
+ LEAVE error FI;
+ last error := error message;
+ putline (err, "EOLN " + text (zeile) + " " + error message);
+ IF online THEN put (zeile); putline (error message) FI
+END PROC error;
+
+TEXT PROC bytes (INT CONST kilobytes, bytes) :
+ TEXT VAR t :: text (kilobytes);
+ IF bytes < 10 THEN t CAT "00"
+ ELIF bytes < 100 THEN t CAT "0"
+ FI;
+ t CAT text (bytes);
+ t CAT " Byte";
+ t
+END PROC bytes
+
+END PACKET mpg test elan programs;
+
+(************************* ARCHIV **********************************)
+
+PACKET mpg archive system DEFINES reserve, archive, release,
+ archiv, archiv name,archiv error,
+ archiv angemeldet,
+ from, to,
+ pla :
+
+
+LET archive 0 code = 90,
+ archive 1 code = 91,
+ altos archive 0 = 0,
+ altos archive 1 = 1,
+ bicos archive 0 = 2,
+ altos station = 1,
+ free code = 20,
+ reserve code = 19,
+ type = "#type (""micron"")#",
+ configurator = "configurator";
+
+BOOL VAR angemeldet;
+TEXT VAR err :: "";
+
+(************************ Standard - Prozeduren ****************************)
+(* Erlaubt jedoch nur eine ARCHIVE-Task *)
+
+PROC reserve (TASK CONST task):
+ reserve ("", task)
+END PROC reserve;
+
+PROC reserve (TEXT CONST msg, TASK CONST task):
+ IF task = archive
+ THEN angemeldet := TRUE
+ FI;
+ call (reserve code, msg, task)
+END PROC reserve;
+
+PROC archive (TEXT CONST name):
+ reserve (name, archive)
+END PROC archive;
+
+PROC archive (TEXT CONST name, INT CONST station):
+ reserve (name,station/archive)
+END PROC archive;
+
+PROC archive (TEXT CONST name, TASK CONST task):
+ reserve (name, task)
+END PROC archive;
+
+PROC release (TASK CONST task):
+ call (free code, "", task);
+ IF task = archive
+ THEN angemeldet := FALSE
+ FI
+END PROC release;
+
+PROC release :
+ release (archive);
+END PROC release;
+
+PROC archiv (INT CONST nr):
+ SELECT nr OF
+ CASE altos archive 0, altos archive 1: altos anmelden
+ CASE bicos archive 0 : archiv
+ OTHERWISE unbekannte laufwerksnummer
+ END SELECT.
+
+ altos anmelden:
+ IF station (myself) <> altos station
+ THEN unbekannte laufwerksnummer
+ ELSE reserve (archive);
+ SELECT nr OF
+ CASE altos archive 0: call (archive 0 code, "",task(configurator))
+ CASE altos archive 1: call (archive 1 code, "",task(configurator))
+ END SELECT;
+ archiv
+ FI.
+
+ unbekannte laufwerksnummer:
+ errorstop ("Unbekannte Laufwerksnummer")
+END PROC archiv;
+
+PROC archiv :
+ angemeldet := TRUE;
+ TEXT CONST name :: archiv name;
+ IF err = ""
+ THEN display ("Gefundenes Archiv: """ + name + """");
+ ELSE errorstop (err)
+ FI;
+ display (""13""10"").
+
+END PROC archiv;
+
+BOOL PROC archiv angemeldet:
+ angemeldet
+END PROC archiv angemeldet;
+
+TEXT PROC archiv name:
+ TEXT VAR name :: "";
+ THESAURUS VAR th;
+ IF NOT angemeldet
+ THEN errorstop ("Archiv nicht angemeldet");""
+ ELSE angemeldet := FALSE;
+ err := "";
+ disable stop;
+ archive ("");
+ IF is error
+ THEN err := errormessage;
+ LEAVE archiv name WITH ""
+ FI;
+ th := ALL archive;
+ richtigen namen suchen;
+ clear error;
+ enable stop;
+ archive (name);
+ angemeldet := TRUE;
+ name
+ FI.
+
+richtigen namen suchen:
+ IF subtext (error message, 1, 13) = "Archiv heisst"
+ THEN name := subtext (error message, 16, LENGTH error message - 1)
+ ELSE err := error message
+ FI
+END PROC archiv name;
+
+TEXT PROC archiv error:
+ err
+END PROC archiv error;
+
+PROC from (TEXT CONST name) :
+ fetch (name, archive)
+END PROC from;
+
+PROC to (TEXT CONST name) :
+ BOOL CONST cd :: command dialogue;
+ command dialogue (FALSE);
+ save (name, archive);
+ command dialogue (cd)
+END PROC to;
+
+PROC to :
+ to (last param)
+END PROC to;
+
+PROC from (THESAURUS CONST nameset):
+ fetch (nameset, archive)
+END PROC from;
+
+PROC to (THESAURUS CONST nameset):
+ BOOL CONST cd :: command dialogue;
+ command dialogue (FALSE);
+ save (nameset, archive);
+ command dialogue (cd)
+END PROC to;
+
+PROC pla:
+ LET dummy name pos = 18;
+
+ FILE VAR listfile;
+ INT VAR i;
+ TEXT CONST head :: 70 * "=",
+ end :: 70 * "_";
+ TEXT VAR record;
+ WHILE yes ("Archiv eingelegt") REP
+ print archive listing
+ PER;
+ release.
+
+print archive listing:
+ archiv;
+ listfile := sequential file (output , "PLA");
+ list (listfile, archive);
+ print head;
+ erase dummy names;
+ print bottom;
+ print and erase listing.
+
+print head :
+ modify (listfile);
+ to line (listfile, 1);
+ FOR i FROM 1 UPTO 6 REP
+ insert record (listfile)
+ PER;
+ to line (listfile, 1);
+ write record (listfile, type); down (listfile);
+ write record (listfile, head); down (listfile);
+ write record (listfile, "ARCHIVNAME: "+headline (listfile) + " " +
+ time of day +" " + date ); down (listfile);
+ write record (listfile, head); down (listfile);
+ write record (listfile, " "); down (listfile);
+ write record (listfile, "Date Store Contents").
+
+erase dummy names :
+ to line (listfile, 6);
+ WHILE NOT eof (listfile) REP
+ read record (listfile, record);
+ IF (record SUB dummy name pos) = "-"
+ THEN delete record (listfile)
+ ELSE down (listfile)
+ FI
+ PER.
+
+print bottom :
+ output (listfile);
+ putline (listfile, end).
+
+print and erase listing :
+ modify (listfile);
+ edit (listfile);
+ line (3);
+ IF yes ("Archivlisting drucken")
+ THEN print ("PLA")
+ FI;
+ forget ("PLA", quiet)
+END PROC pla
+
+END PACKET mpg archive system;
+
+(************************ MPG SOME TOOLS *********************)
+
+PACKET mpg some (*************************)
+ (* Klaus Bovermann *)
+ (* Andreas Dieckmann *)
+ (* Thomas Clermont *)
+ (* Version 3.2 *)
+ (* EUMEL 1.8.1 *)
+ (* Datum: 21.10.87 *)
+ (*************************)
+
+DEFINES some, SOME, (* in mehreren Versionen *)
+ one, (* in mehreren Versionen *)
+ inchar, (* *)
+ center, (* Hilfsroutinen *)
+ invers , (* *)
+ edit some, (* fuer Anfaenger *)
+ edit one, (* fuer Anfaenger *)
+
+ reorganize: (* auf Thesaurus *)
+
+LET max bild laenge = 80;
+
+TEXT PROC center (TEXT CONST n):
+ center (n," ",max bild laenge - 1)
+END PROC center;
+
+TEXT PROC center (TEXT CONST n,fuell zeichen,INT CONST max text laenge):
+ TEXT VAR fuell text ::
+ ((max text laenge - length (n)) DIV 2) * fuell zeichen;
+ fuelltext CAT (n + fuelltext);
+ IF (LENGTH fuelltext) - max text laenge = 0
+ THEN fuelltext
+ ELSE fuelltext + fuellzeichen
+ FI
+END PROC center;
+
+TEXT PROC invers (TEXT CONST n):
+ mark ein + n + " " + mark aus
+END PROC invers;
+
+PROC inchar (TEXT VAR t, TEXT CONST allowed chars):
+ enable stop;
+ REP getchar (t); (* Auslesen nur aus virtuellem Puffer *)
+ IF pos (allowed chars,t) = 0
+ THEN out (""7"")
+ FI
+ UNTIL pos (allowed chars,t) <> 0 PER
+END PROC inchar;
+
+(*********************************************************************)
+
+LET min zeilen = 3,
+ bildschirm = 24,
+ min x size = 30,
+ max entries = 200;
+
+LET trennzeichen = ""222"", (* ESC # *)
+ zeichenstring = ""1""27""3""10""13"x"12"o?"11"",
+ oben unten rubout o return x = ""3""10""12"o"13"x",
+ q eins neun a return x rubout o s = "q19a"13"x"12"os";
+
+LET mark ein = ""15"",
+ mark aus = ""14"";
+
+LET stdtext1 = "Auswahl einer Datei ",
+ stdtext2 = "Auswahl mehrerer Dateien ",
+ stdhelp = "( Bei Unklarheiten bitte <?> )";
+
+LET hop = 1,
+ esc = 2,
+ obe = 3,
+ unt = 4,
+ ank = 5,
+ ank 1 = 6,
+ aus = 7,
+ aus 1 = 8,
+ fra = 9,
+ ins = 10;
+
+LET filetype = 1003;
+
+INT VAR anzahl, begin x,begin y,
+ kopf zeilen , size x,size y,
+ max eintraege,
+ realc,
+ virtc;
+
+TEXT VAR string,
+ weitertext,
+ niltext,
+ kopfzeilen text,
+ kz1,
+ kz2;
+
+BOOL VAR raender,
+ auswahlende,
+ abbruch;
+
+ROW max entries TEXT VAR eintrag;
+
+THESAURUS VAR gesamt liste;
+FILE VAR tools info;
+DATASPACE VAR tools info ds;
+
+INITFLAG VAR init tools info;
+
+(******************* Grundlegende Prozedur *************************)
+
+THESAURUS PROC einzelne (THESAURUS CONST t, BOOL CONST viele,
+ TEXT CONST k1,
+ INT CONST x begin,y begin,
+ x size ,y size):
+ begin x := x begin;
+ begin y := y begin;
+ size x := x size;
+ size y := y size;
+ kz1 := k1;
+ string := "";
+ raender := FALSE;
+ gen kopf zeilen;
+ IF groesster editor > 0
+ THEN INT VAR x,y;
+ get edit cursor (x,y) ;
+ IF bildschirm - kopfzeilen - min zeilen + 1 < y
+ THEN begin y := 1;
+ size y := 24;
+ begin x := 1;
+ size x := 79
+ ELSE begin y := y;
+ size y := bildschirm - y + 1;
+ max eintraege := size y - min zeilen - kopfzeilen;
+ IF (80 - x) < min x size OR col = 1
+ THEN begin x := 1;
+ size x := 79
+ ELSE raender := TRUE;
+ begin x := x;
+ size x := 80 - x - 2
+ FI
+ FI;
+ gen kopfzeilen
+ FI;
+ IF (size y - kopf zeilen) < min zeilen OR
+ begin y < 0 OR
+ (begin y + size y - 1) > bildschirm OR
+ (begin x + size x - 1) > 79
+ THEN errorstop ("Fenster zu klein")
+ FI;
+ init weitertext;
+ init niltext;
+ THESAURUS VAR ausgabe :: empty thesaurus;
+ gesamt liste := t;
+ INT VAR i;
+ anzahl := 0;
+ FOR i FROM 1 UPTO highest entry (t) REP
+ IF name (t,i) <> ""
+ THEN anzahl INCR 1;
+ eintrag [anzahl] := name (t,i)
+ FI
+ PER;
+ IF anzahl = 0 THEN LEAVE einzelne WITH ausgabe FI;
+ bild aufbauen;
+ abbruch := FALSE;
+ kreuze an (viele);
+ IF abbruch
+ THEN LEAVE einzelne WITH ausgabe
+ FI;
+ cursor (begin x,begin y + size y - 1);
+ out (niltext); (* Folgende Ausgaben werden sonst unleserlich *)
+ ausgabe erzeugen;
+ ausgabe.
+
+ausgabe erzeugen:
+ TEXT VAR nam;
+ WHILE string <> "" REP
+ nam := subtext (string,1,3);
+ string := subtext (string,5);
+ insert (ausgabe, eintrag [int (nam)])
+ PER
+END PROC einzelne;
+
+PROC realcursor setzen:
+ cursor (begin x,kopf zeilen + realc + begin y);
+ IF raender
+ THEN out ("|")
+ FI;
+ out (marke (virtc, TRUE) + 6 * ""8"")
+END PROC real cursor setzen;
+
+TEXT PROC marke (INT CONST zeiger, BOOL CONST mit cursor):
+ INT VAR pl :: nr (zeiger);
+ IF pl = 0
+ THEN leer
+ ELSE mit zahl
+ FI.
+
+mit zahl:
+ IF mit cursor
+ THEN (3-length(text(pl))) * "-" + text (pl) + "-> "
+ ELSE text (pl,3) + " > "
+ FI.
+
+leer:
+ IF mit cursor
+ THEN "----> "
+ ELSE 6 * " "
+ FI
+END PROC marke;
+
+PROC init weitertext:
+ weitertext := "----> " + mark ein + "weitere Eintraege " + mark aus
+ + ((size x - 27) * "-")
+END PROC init weitertext;
+
+PROC init niltext:
+ IF size x > 78
+ THEN niltext := ""5""
+ ELSE IF raender
+ THEN niltext := ((size x + 2) * " " + (size x + 2) * ""8"")
+ ELSE niltext := (size x * " " + size x * ""8"")
+ FI
+ FI
+END PROC init niltext;
+
+PROC bild (INT CONST anfang):
+ INT VAR i;
+ gib oberlinie aus;
+ FOR i FROM anfang UPTO grenze REP
+ cursor (begin x,kopfzeilen + begin y + i - anfang + 1);
+ rand;
+ out (marke (i, FALSE));
+ IF LENGTH ("""" + eintrag [i] + """") <= (size x - 6)
+ THEN out (text ("""" + eintrag [i] + """",size x - 6))
+ ELSE out (text ("""" + eintrag [i],size x - 10) + " ...")
+ FI;
+ rand
+ PER;
+ gib unterlinie aus;
+ IF grenze < (anfang + max eintraege)
+ THEN FOR i FROM 0 UPTO (anfang + max eintraege - anzahl - 1) REP
+ cursor (begin x,begin y + kopfzeilen + i +
+ grenze - anfang + min zeilen);
+ out (niltext)
+ PER
+ FI.
+
+gib oberlinie aus:
+ cursor (begin x,kopfzeilen + begin y);
+ rand;
+ IF realc = virtc
+ THEN out (size x * "-")
+ ELSE out (weitertext)
+ FI;
+ rand.
+
+gib unterlinie aus:
+ cursor (begin x,begin y + grenze - anfang + kopfzeilen + min zeilen - 1);
+ rand;
+ IF anzahl <= (anfang + max eintraege)
+ THEN out (size x * "-")
+ ELSE out (weitertext)
+ FI;
+ rand.
+
+grenze:
+ min (anzahl,anfang + max eintraege).
+
+END PROC bild;
+
+PROC gen kopfzeilen:
+ kopfzeilen := 0;
+ kopfzeilen text := "";
+ kopfzeilen text CAT code (0);
+ IF pos (kz1,trenn zeichen) > 0
+ THEN analysiere kopfzeile
+ ELIF kz1 <> "" AND length (kz1) <= size x
+ THEN kopfzeilen text := kz1 + code (1);
+ kopf zeilen := 1
+ ELIF kz1 <> ""
+ THEN analysiere kopfzeile
+ FI;
+ IF kopfzeilen > size y - min zeilen
+ THEN kopfzeilen := size y - min zeilen
+ FI;
+ max eintraege := size y - kopfzeilen - min zeilen.
+
+analysiere kopfzeile:
+ kz2 := compress (kz1);
+ BOOL VAR mark is on :: FALSE;
+ TEXT VAR einschub;
+ REP kopf zeilen INCR 1;
+ kontrolliere pos;
+ einschub := subtext(kz2,1,pos (kz2,trennzeichen)-1);
+ kontrolliere auf markiert;
+ kopfzeilen text CAT einschub;
+ kopfzeilen text CAT code (kopf zeilen);
+ kz2 := compress (subtext(kz2,pos (kz2,trennzeichen) + 1));
+ UNTIL NOT (length (kz2) > size x OR pos (kz2,trennzeichen) > 0 )PER;
+ IF kz2 <> ""
+ THEN einschub := kz2;
+ kontrolliere auf markiert;
+ kopfzeilen text CAT einschub;
+ kopf zeilen INCR 1
+ FI;
+ kopfzeilentext CAT code (kopfzeilen).
+
+muss noch getrennt werden:
+ (pos (kz2,trennzeichen) > size x OR pos (kz2,trennzeichen) = 0)
+ AND length (kz2) > size x.
+
+kontrolliere pos:
+ IF muss noch getrennt werden
+ THEN trenne kopfzeile
+ FI.
+
+trenne kopfzeile:
+ INT VAR i;
+ FOR i FROM size x DOWNTO (size x DIV 2) REP
+ UNTIL (kz2 SUB i) = " " PER;
+ kz2 := subtext (kz2,1,i) + trennzeichen + subtext (kz2,i+1).
+
+kontrolliere auf markiert:
+ IF mark is on
+ THEN kopfzeilen text CAT mark ein;
+ IF pos (einschub,mark aus) > 0 AND pos (einschub,mark ein) = 0
+ THEN mark is on := FALSE
+ FI
+ ELSE IF pos (einschub,mark ein) > 0
+ THEN IF pos (einschub,mark aus) = 0
+ THEN einschub CAT mark aus;
+ mark is on := TRUE
+ FI
+ FI
+ FI.
+
+END PROC gen kopfzeilen;
+
+PROC zeige kopfzeilen:
+ INT VAR i;
+ FOR i FROM 1 UPTO kopfzeilen REP
+ cursor (begin x,begin y + i - 1);
+ rand;
+ out (niltext);
+ out (center (subtext (kopfzeilen text,pre code + 1,post code - 1)
+ ," ",size x));
+ rand
+ PER.
+
+ post code:
+ pos (kopfzeilen text,code (i)).
+
+ pre code:
+ pos (kopfzeilen text,code (i - 1)).
+
+END PROC zeige kopfzeilen;
+
+PROC bild aufbauen:
+ zeige kopfzeilen;
+ virtc := 1;
+ realc := 1;
+ bild (1);
+ realcursor setzen
+END PROC bild aufbauen;
+
+PROC kreuze an (BOOL CONST viele):
+ auswahlende := FALSE;
+ REP zeichen lesen;
+ zeichen interpretieren
+ UNTIL auswahlende
+ PER.
+
+zeichen lesen:
+ TEXT VAR zeichen;
+ inchar (zeichen, zeichenstring).
+
+zeichen interpretieren:
+ SELECT pos (zeichenstring, zeichen) OF
+ CASE hop : hoppen (viele)
+ CASE esc : esc kommandos (viele)
+ CASE obe : nach oben
+ CASE unt : nach unten
+ CASE ank : ankreuzen (viele,FALSE); evtl aufhoeren
+ CASE ank 1 : ankreuzen (viele,TRUE ); evtl aufhoeren
+ CASE aus : auskreuzen
+ CASE aus 1 : auskreuzen
+ CASE fra : info (viele)
+ CASE ins : eintrag einfuegen;
+ IF string <> ""
+ THEN evtl aufhoeren
+ FI
+ END SELECT.
+
+evtl aufhoeren:
+ IF NOT viele
+ THEN LEAVE kreuze an
+ FI
+END PROC kreuze an;
+
+PROC hoppen (BOOL CONST viele):
+ zweites zeichen lesen;
+ zeichen interpretieren.
+
+zweites zeichen lesen:
+ TEXT VAR zz;
+ getchar (zz).
+
+zeichen interpretieren:
+ SELECT pos (oben unten rubout o return x , zz) OF
+ CASE 0 : out (""7"")
+ CASE 1 : hop nach oben
+ CASE 2 : hop nach unten
+ CASE 3,4 : alles loeschen
+ CASE 5 : bild nach oben
+ CASE 6 : IF viele THEN rest ankreuzen ELSE out (""7"") FI
+ END SELECT.
+
+bild nach oben:
+ realc := 1;
+ bild (virtc);
+ realcursor setzen.
+
+rest ankreuzen:
+ INT VAR i;
+ FOR i FROM 1 UPTO anzahl REP
+ IF nr (i) = 0
+ THEN string CAT textstr (i)
+ FI
+ PER;
+ bild aktualisieren;
+ realcursor setzen.
+
+alles loeschen:
+ string := "";
+ bild aktualisieren;
+ realcursor setzen.
+
+hop nach oben:
+ IF ganz oben
+ THEN out (""7"")
+ ELIF oben auf der seite
+ THEN raufblaettern
+ ELSE top of page
+ FI.
+
+ganz oben:
+ virtc = 1.
+
+oben auf der seite:
+ realc = 1.
+
+raufblaettern:
+ virtc DECR (max eintraege + 1);
+ virtc := max (virtc, 1);
+ bild (virtc);
+ realcursor setzen.
+
+top of page:
+ loesche marke;
+ virtc DECR (realc - 1);
+ realc := 1;
+ realcursor setzen.
+
+hop nach unten:
+ IF ganz unten
+ THEN out (""7"")
+ ELIF unten auf der seite
+ THEN runterblaettern
+ ELSE bottom of page
+ FI.
+
+ganz unten:
+ virtc = anzahl.
+
+unten auf der seite:
+ realc > maxeintraege .
+
+runterblaettern:
+ INT VAR alter virtc :: virtc;
+ virtc INCR (max eintraege + 1);
+ virtc := min (virtc, anzahl);
+ realc := virtc - alter virtc;
+ bild (alter virtc + 1);
+ realcursor setzen.
+
+bottom of page:
+ loesche marke;
+ alter virtc := virtc;
+ virtc INCR (max eintraege + 1 - realc);
+ virtc := min (anzahl, virtc);
+ realc INCR (virtc - alter virtc);
+ realcursor setzen
+END PROC hoppen;
+
+PROC esc kommandos (BOOL CONST viele):
+ TEXT VAR zz;
+ getchar (zz);
+ SELECT pos(q eins neun a return x rubout o s, zz) OF
+ CASE 0 : out (""7"")
+ CASE 1 : auswahlende := TRUE
+ CASE 2 : zeige anfang
+ CASE 3 : zeige ende
+ CASE 4 : abbruch := TRUE; auswahlende := TRUE
+ CASE 5,6 : IF viele
+ THEN ankreuzen bis ende
+ ELSE out (""7"")
+ FI
+ CASE 7,8 : IF viele
+ THEN loeschen bis ende
+ ELSE out (""7"")
+ FI
+ CASE 9 : liste nach nummern ordnen
+ END SELECT.
+
+liste nach nummern ordnen :
+ THESAURUS VAR dummy thesaurus :: empty thesaurus;
+ TEXT VAR nam,dummy string :: "";
+ cursor (begin x,begin y + screen ende + kopfzeilen + minzeilen - 1);
+ rand;
+ out (center(invers("Bitte warten !"),"-",size x));
+ rand;
+ i := 0;
+ WHILE string <> "" REP
+ i INCR 1;
+ nam := subtext (string,1,3);
+ string := subtext (string,5);
+ insert (dummy thesaurus, eintrag [int (nam)]);
+ dummy string CAT textstr (i)
+ PER;
+ anzahl := 0;
+ string := dummy string;
+ gesamt liste := dummy thesaurus + gesamt liste;
+ FOR i FROM 1 UPTO highest entry (gesamt liste) REP
+ IF name (gesamt liste,i) <> ""
+ THEN anzahl INCR 1;
+ eintrag [anzahl] := name (gesamt liste,i)
+ FI
+ PER;
+ bild aufbauen.
+
+loeschen bis ende:
+ INT VAR j;
+ FOR j FROM virtc UPTO anzahl REP
+ INT VAR posi :: nr (j);
+ IF posi <> 0
+ THEN rausschmeissen
+ FI
+ PER;
+ bild aktualisieren;
+ realcursor setzen.
+
+rausschmeissen:
+ string := subtext (string,1, 4*posi-4) + subtext (string,4*posi+1).
+
+ankreuzen bis ende:
+ INT VAR i;
+ FOR i FROM virtc UPTO anzahl REP
+ IF nr (i) = 0
+ THEN string CAT textstr (i)
+ FI
+ PER;
+ bild aktualisieren;
+ realcursor setzen.
+
+zeige anfang:
+ IF virtc = 1
+ THEN out (""7"")
+ ELIF virtc = realc
+ THEN loesche marke;
+ virtc := 1;
+ realc := 1;
+ realcursor setzen
+ ELSE virtc := 1;
+ realc := 1;
+ bild (1);
+ realcursor setzen
+ FI.
+
+zeige ende:
+ IF virtc = anzahl
+ THEN out (""7"")
+ ELIF ende auf screen
+ THEN loesche marke;
+ realc INCR (anzahl - virtc);
+ virtc := anzahl;
+ realcursor setzen
+ ELSE virtc := anzahl;
+ realc := max eintraege + 1;
+ bild (anzahl - maxeintraege);
+ realcursor setzen
+ FI.
+
+ende auf screen:
+ (realc + anzahl - virtc) < maxeintraege + 1.
+
+screen ende:
+ min (realc + anzahl - virtc - 1,max eintraege).
+
+END PROC esc kommandos;
+
+PROC ankreuzen (BOOL CONST viele,xo):
+ INT VAR pl :: nr (virtc);
+ IF pl <> 0
+ THEN out (""7"");
+ cursor setzen;
+ LEAVE ankreuzen
+ FI;
+ string CAT textstr (virtc);
+ IF viele
+ THEN cursor setzen
+ FI.
+
+ cursor setzen:
+ IF xo
+ THEN realcursor setzen
+ ELSE IF virtc < anzahl
+ THEN nach unten
+ FI;
+ IF virtc = anzahl
+ THEN realcursor setzen
+ FI
+ FI
+END PROC ankreuzen;
+
+PROC auskreuzen :
+ INT VAR posi :: nr (virtc);
+ IF posi = 0
+ THEN out (""7""); LEAVE auskreuzen
+ FI;
+ rausschmeissen;
+ loesche marke;
+ bild aktualisieren;
+ realcursor setzen.
+
+rausschmeissen:
+ string := subtext (string,1, 4*posi-4) + subtext (string,4*posi+1)
+END PROC auskreuzen;
+
+PROC eintrag einfuegen :
+ IF anzahl = max entries
+ THEN out (""7"");
+ LEAVE eintrag einfuegen
+ FI;
+ mache platz frei;
+ trage ein;
+ baue richtiges bild auf.
+
+mache platz frei:
+ INT VAR i;
+ FOR i FROM anzahl DOWNTO virtc REP
+ eintrag [i+1] := eintrag [i]
+ PER;
+ eintrag [virtc] := """";
+ ruecke kreuze einen weiter;
+ anzahl INCR 1;
+ string CAT textstr (virtc);
+ baue richtiges bild auf.
+
+trage ein:
+ TEXT VAR exit char;
+ realcursor setzen;
+ out (marke (virtc,TRUE));
+ out ("""");
+ push (""11"");
+ editget (ein,max text length,size x - 7,"","",exit char);
+ IF (ein SUB length (ein)) = """"
+ THEN ein := subtext (ein,1,length (ein) - 1)
+ FI;
+ IF ein = ""
+ THEN auskreuzen;
+ setze eintraege zurueck
+ ELSE realcursor setzen;
+ out (6 * ""2"" + text ("""" + ein + """",size x - 7))
+ FI.
+
+ein:
+ eintrag [virtc].
+
+setze eintraege zurueck:
+ FOR i FROM virtc UPTO anzahl-1 REP
+ eintrag [i] := eintrag [i+1];
+ change (string,textstr (i+1),textstr (i))
+ PER;
+ anzahl DECR 1.
+
+ruecke kreuze einen weiter:
+ FOR i FROM anzahl DOWNTO virtc REP
+ change (string,textstr (i),textstr (i+1))
+ PER.
+
+baue richtiges bild auf:
+ bild (virtc - (realc - 1));
+ realcursor setzen
+END PROC eintrag einfuegen;
+
+PROC bild aktualisieren:
+ INT VAR ob, un, i;
+ ob := virtc - (realc - 1);
+ un := min (ob + max eintraege, anzahl);
+ FOR i FROM ob UPTO un REP
+ cursor (begin x,kopfzeilen + begin y + i - ob + 1);
+ rand;
+ out (marke (i, FALSE))
+ PER
+END PROC bild aktualisieren;
+
+PROC nach oben:
+ IF noch nicht oben (* virtuell *)
+ THEN gehe nach oben
+ ELSE out (""7"")
+ FI.
+
+noch nicht oben:
+ virtc > 1.
+
+gehe nach oben:
+ IF realc = 1
+ THEN scroll down
+ ELSE cursor up
+ FI.
+
+scroll down:
+ virtc DECR 1;
+ bild (virtc);
+ realcursor setzen.
+
+cursor up:
+ loesche marke;
+ virtc DECR 1;
+ realc DECR 1;
+ realcursor setzen
+END PROC nach oben;
+
+PROC nach unten:
+ IF noch nicht unten (* virtuell *)
+ THEN gehe nach unten
+ ELSE out (""7"")
+ FI.
+
+noch nicht unten:
+ virtc < anzahl.
+
+gehe nach unten:
+ IF realc > maxeintraege
+ THEN scroll up
+ ELSE cursor down
+ FI.
+
+scroll up:
+ virtc INCR 1;
+ bild (virtc - maxeintraege);
+ realcursor setzen.
+
+cursor down:
+ loesche marke;
+ virtc INCR 1;
+ realc INCR 1;
+ realcursor setzen
+END PROC nach unten;
+
+PROC loesche marke:
+ cursor (begin x,kopf zeilen + realc + begin y);
+ rand;
+ out (marke (virtc, FALSE))
+END PROC loesche marke;
+
+TEXT PROC textstr (INT CONST nr):
+ text (nr,3) + "!"
+END PROC textstr;
+
+INT PROC nr (INT CONST zeiger):
+ IF pos (string, textstr (zeiger)) = 0
+ THEN 0
+ ELSE (pos (string,textstr (zeiger)) DIV 4) + 1
+ FI
+END PROC nr;
+
+PROC rand:
+ IF raender
+ THEN out ("|")
+ FI
+END PROC rand;
+
+PROC info (BOOL CONST mehrere moeglich):
+ IF NOT initialized (init tools info)
+ THEN initialisiere tools info
+ FI;
+ modify (tools info);
+ IF mehrere moeglich
+ THEN head line (tools info," INFO : Auswahl mehrerer Dateien ");
+ ELSE head line (tools info," INFO : Auswahl einer Datei ");
+ FI;
+ to line (tools info,1);
+ col (tools info,1);
+ IF raender
+ THEN open editor (groesster editor + 1,tools info,FALSE,
+ begin x,begin y,size x + 2,size y)
+ ELSE open editor (groesster editor + 1,tools info,FALSE,
+ begin x,begin y,size x,size y)
+ FI;
+ edit (groesster editor,"q19",PROC (TEXT CONST) std kommando interpreter);
+ zeige kopfzeilen;
+ bild (virtc - (realc - 1));
+ realcursor setzen
+END PROC info;
+
+(******************** Herausgereichte, abgeleitete Prozeduren ***********)
+
+THESAURUS PROC some (THESAURUS CONST t,TEXT CONST kopf zeile,
+ INT CONST start x,start y,x size,y size):
+ einzelne (t,TRUE,kopf zeile,start x,start y,x size,y size)
+END PROC some;
+
+THESAURUS PROC some (THESAURUS CONST t,
+ INT CONST start x,start y,x size,y size):
+ some (t,invers (std text 2 + std help),start x,start y,x size,y size)
+END PROC some;
+
+THESAURUS PROC some (THESAURUS CONST t,TEXT CONST kopf zeile,
+ INT CONST start y,ende y):
+ einzelne (t,TRUE,kopf zeile,1,start y,79,ende y - start y + 1)
+END PROC some;
+
+THESAURUS PROC some (THESAURUS CONST t,INT CONST start y,ende y):
+ some (t,invers(stdtext 2 + std help),1,start y,79,ende y - start y + 1)
+END PROC some;
+
+THESAURUS PROC some (THESAURUS CONST t,TEXT CONST kopf zeile):
+ some (t,kopf zeile,1,bildschirm)
+END PROC some;
+
+THESAURUS PROC some (THESAURUS CONST t):
+ some (t,invers(stdtext 2 + std help),1,bildschirm)
+END PROC some;
+
+THESAURUS PROC some:
+ some (all,invers(stdtext 2 + std help),1,bildschirm)
+END PROC some;
+
+THESAURUS PROC some (TEXT CONST te):
+ some (ALL te)
+END PROC some;
+
+THESAURUS PROC some (TASK CONST quelle):
+ some (ALL quelle)
+END PROC some;
+
+THESAURUS OP SOME (THESAURUS CONST th):
+ some (th)
+END OP SOME;
+
+THESAURUS OP SOME (TASK CONST ta):
+ some (ALL ta)
+END OP SOME;
+
+THESAURUS OP SOME (TEXT CONST te):
+ some (ALL te)
+END OP SOME;
+
+TEXT PROC one (THESAURUS CONST t,TEXT CONST kopf zeile,
+ INT CONST start x,start y,x size,y size):
+ name(einzelne (t,FALSE,kopf zeile,start x,start y,x size,y size),1)
+END PROC one;
+
+TEXT PROC one (THESAURUS CONST t,
+ INT CONST start x,start y,x size,y size):
+ one (t,invers (std text 1 + std help),start x,start y,x size,y size)
+END PROC one;
+
+TEXT PROC one (THESAURUS CONST t, TEXT CONST t1,
+ INT CONST start y,ende y):
+ name (einzelne (t,FALSE, t1,1,start y,79,ende y - start y + 1), 1)
+END PROC one;
+
+TEXT PROC one (THESAURUS CONST t,
+ INT CONST start y,ende y):
+ one (t,invers (std text 1+ std help),1,start y,79,ende y - start y + 1)
+END PROC one;
+
+TEXT PROC one (THESAURUS CONST t,TEXT CONST kopf zeile):
+ one (t,kopf zeile,1,bildschirm)
+END PROC one;
+
+TEXT PROC one (THESAURUS CONST t):
+ one (t,invers(stdtext 1 + std help),1,bildschirm)
+END PROC one;
+
+TEXT PROC one (TASK CONST quelle):
+ one (ALL quelle)
+END PROC one;
+
+TEXT PROC one:
+ one (all)
+END PROC one;
+
+TEXT PROC one (TEXT CONST te):
+ one (ALL te)
+END PROC one;
+
+PROC edit one :
+ TEXT CONST datei :: one (all,invers(stdtext 1 + "zum Editieren")
+ + trennzeichen + stdhelp,
+ 1,bildschirm);
+ IF datei <> "" CAND (NOT exists (datei)
+ COR type (old (datei)) = filetype)
+ THEN IF groesster editor > 0
+ THEN ueberschrift neu;
+ bild neu
+ FI;
+ edit (datei)
+ FI
+END PROC edit one;
+
+PROC edit some:
+ THESAURUS CONST tt :: some (all,invers(stdtext 2 + "zum Editieren")
+ + trennzeichen + stdhelp,
+ 1,bildschirm); INT VAR i;
+ FOR i FROM 1 UPTO highest entry (tt) REP
+ TEXT VAR datei :: name (tt,i);
+ IF datei <> "" CAND (NOT exists (datei)
+ COR type (old (datei)) = filetype)
+ THEN IF groesster editor > 0
+ THEN ueberschrift neu;
+ bild neu
+ FI;
+ edit (datei)
+ FI
+ PER
+END PROC edit some;
+
+PROC reorganize (THESAURUS CONST t):
+ page;
+ do (PROC (TEXT CONST) do reorganize,t)
+END PROC reorganize;
+
+PROC do reorganize (TEXT CONST name):
+ IF type (old(name)) = file type
+ THEN put ("Datei " + center (invers("""" + name + """")," ",30)
+ + " wird reorganisiert :");
+ FILE VAR file :: sequential file (modify,name);
+ IF segments (file) = 1
+ THEN put (lines (file))
+ ELSE reorganize (name)
+ FI
+ ELSE put (" " + center (invers("""" + name + """")," ",30)
+ + " ist keine Datei.")
+ FI;
+ line
+END PROC do reorganize ;
+
+PROC initialisiere tools info :
+ tools info ds := nilspace;
+ tools info := sequential file (output, tools info ds);
+ putline (tools info,""15" Mit den angekreuzten Namen wird die gewaehlte Operation ausgefuehrt "14"");
+ line (tools info);
+ putline (tools info," "15" Positionierungen: "14" ");
+ line (tools info);
+ putline (tools info," Oben : zum vorausgehenden Namen");
+ putline (tools info," Unten : zum folgenden Namen ");
+ putline (tools info," HOP Oben : zum ersten Namen der (vorigen) Seite");
+ putline (tools info," HOP Unten : zum letzten Namen der (vorigen) Seite");
+ putline (tools info," HOP RETURN : aktuelle Zeile wird erste Zeile");
+ putline (tools info," ESC 1 : zum ersten Namen der Liste");
+ putline (tools info," ESC 9 : zum letzten Namen der Liste");
+ putline (tools info," ESC s : Liste nach Nummern ordnen");
+ line (tools info);
+ putline (tools info," "15" Auswahl treffen: "14" ");
+ line (tools info);
+ putline (tools info," ( Folgende Befehle sind nur bei einer )");
+ putline (tools info," ( Auswahl von mehreren Namen Möglich. )");
+ line (tools info);
+ putline (tools info," RETURN bzw. x: diesen Namen ankreuzen ");
+ putline (tools info," RUBOUT bzw. o: Kreuz vor dem Namen loeschen");
+ putline (tools info," HOP x : alle Namen ankreuzen ");
+ putline (tools info," HOP o : alle Kreuze loeschen ");
+ putline (tools info," ESC x : alle folgenden Namen ankreuzen");
+ putline (tools info," ESC o : alle folgenden Kreuze loeschen");
+ putline (tools info," RUBIN : einen neuen Namen eintragen");
+ line (tools info);
+ putline (tools info," ( Nur dieser Befehl kann benutzt werden , wenn )");
+ putline (tools info," ( die Auswahl eines ! Namens möglich ist. )");
+ line (tools info);
+ putline (tools info," RETURN bzw. x: diesen Namen auswaehlen");
+ line (tools info);
+ putline (tools info," "15" Auswahl verlassen: "14"");
+ line (tools info);
+ putline (tools info," ESC q : Auswaehlen beenden ");
+ putline (tools info," ESC a : Auswahl abbrechen (ohne Kreuze !)");
+ line (tools info);
+ putline (tools info,""15" Zum Verlassen des Infos bitte 'ESC q' tippen! "14"");
+END PROC initialisiere tools info;
+
+END PACKET mpg some;
+
+(****************** DATEI MONITOR ********************************)
+
+PACKET mpg dm DEFINES dm: (* Klaus Bovermann *)
+ (* Andreas Dieckmann *)
+ (* Thomas Clermont *)
+ (* Version 2.1 *)
+ (* EUMEL 1.7.5 *)
+ (* Datum 06.05.87 *)
+LET mark ein = ""15"",
+ mark aus = ""14"",
+ trennzeichen = ""222"",
+ type = "#type (""micron"")#",
+ dummy name pos = 18,
+ disk zeichenfolge = "alnfiqushcvd",
+ mana zeichenfolge = "al qush v";
+
+TASK CONST std manager :: task ("PUBLIC");
+TASK VAR manager;
+
+BOOL VAR archive ist meins :: archiv angemeldet,
+ disk ,
+ diskette im schacht :: FALSE;
+
+TEXT VAR aktueller archivename,
+ manager name,
+ t1;
+
+PROC dm:
+ TEXT VAR zeichen, alte lernsequenz :: lernsequenz auf taste ("k");
+ REP aktion
+ UNTIL zeichen = "q" PER;
+ lernsequenz auf taste legen ("k",alte lernsequenz).
+
+aktion:
+ manager := std manager;
+ vormonitor;
+ IF zeichen <> "q" AND managername <> ""
+ THEN hauptmonitor
+ FI.
+
+zeige vormonitor:
+ managername := name (manager);
+ page;
+ write(27 * " "); write(mark ein);
+ write("V O R M O N I T O R "); write(mark aus);
+ line(4);
+ zeile ("t","Task einstellen, mit der kommuniziert werden soll");
+ zeile ("p","Es soll mit 'PUBLIC' kommuniziert werden");
+ zeile ("v","Es soll mit der Vatertask kommuniziert werden");
+ zeile ("a","Es soll mit dem Archiv kommuniziert werden");
+ zeile ("q","Programm beenden").
+
+vormonitor:
+ IF NOT eingabe von erlaubtem zeichen ("tvapq")
+ THEN zeige vormonitor
+ FI;
+ line;
+ write ("Bitte Eingabe : ");
+ inchar (zeichen, "tvapq");
+ out (zeichen); line;
+ IF pos ("a",zeichen) = 0 CAND manager = archive
+ THEN automatische freigabe des archives
+ FI;
+ ausfuehren der vorwahl.
+
+ausfuehren der vorwahl:
+ IF pos ("tvap", zeichen) <> 0
+ THEN neue task einstellen
+ FI.
+
+neue task einstellen:
+ managername := "";
+ IF zeichen = "a" THEN managername := "ARCHIVE"
+ ELIF zeichen = "p" THEN managername := "PUBLIC"
+ ELIF zeichen = "v" THEN managername := name (father)
+ ELSE namen holen
+ FI;
+ TEXT VAR mess;
+ BOOL VAR ok :: managername = "" COR
+ managername = "PUBLIC" COR
+ task ist kommunikativ (managername, mess);
+ IF NOT ok
+ THEN cursor (1,20); putline (""7""15"FEHLER: " + mess + ""14"");
+ pause;
+ managername := "";
+ FI;
+ IF managername = "" THEN manager := std manager
+ ELIF managername = "ARCHIVE" THEN manager := archive
+ ELSE manager := task (managername)
+ FI.
+
+namen holen:
+ REP
+ cursor (1,14);
+ put ("Neue Task:");
+ editget (managername); line;
+ IF managername = name (myself)
+ THEN putline ("Mit der eigenen Task kann nicht kommuniziert werden.")
+ FI;
+ UNTIL managername <> name (myself) PER;
+ lernsequenz auf taste legen ("k",managername).
+
+END PROC dm;
+
+BOOL PROC task ist kommunikativ (TEXT CONST taskname, TEXT VAR message):
+ disable stop;
+ TASK VAR t :: task (taskname);
+ IF is error
+ THEN message := errormessage;
+ clear error;
+ enable stop;
+ FALSE
+ ELSE task behandlung
+ FI.
+
+ task behandlung:
+ IF taskname <> "ARCHIVE"
+ THEN task kommunikation
+ ELSE archive behandlung
+ FI.
+
+ task kommunikation:
+ IF status (t) <> 2
+ THEN message := "Task ist nicht im Wartezustand";
+ enable stop;
+ FALSE
+ ELSE versuchen zuzugreifen
+ FI.
+
+ versuchen zuzugreifen:
+ INT CONST listcode :: 15;
+ DATASPACE VAR dummy :: nilspace;
+ call (listcode, "", dummy, t);
+ forget (dummy);
+ IF is error
+ THEN message := errormessage;
+ clear error;
+ enable stop;
+ FALSE
+ ELSE message := "";
+ enable stop;
+ TRUE
+ FI.
+
+ archive behandlung:
+ IF status (archive) <> 2
+ THEN message := "ARCHIVE ist nicht im Wartezustand";
+ LEAVE archive behandlung WITH FALSE
+ FI;
+ archive ("");
+ IF is error
+ THEN message := errormessage;
+ clear error;
+ enable stop;
+ FALSE
+ ELSE enable stop;
+ archive ist meins := TRUE;
+ diskette im schacht := FALSE;
+ message := "";
+ TRUE
+ FI
+END PROC task ist kommunikativ;
+
+PROC hauptmonitor:
+ disk := (manager = archive);
+ TEXT VAR zeichenfolge;
+ IF disk
+ THEN zeichenfolge := disk zeichenfolge
+ ELSE zeichenfolge := mana zeichenfolge
+ FI;
+ TEXT VAR taste;
+ INT VAR stelle;
+ diskette im schacht := FALSE;
+ IF disk
+ THEN reservieren des archives
+ FI;
+ disable stop;
+ REP
+ IF NOT eingabe von erlaubtem zeichen (zeichenfolge)
+ THEN zeige menue
+ FI;
+ line;
+ write ("Bitte Eingabe : ");
+ inchar (taste,zeichenfolge);
+ out (taste + " Bitte warten...");
+ stelle := pos (disk zeichenfolge, taste); (*!! ACHTUNG !!*)
+ IF stelle > 6
+ AND NOT diskette im schacht
+ AND disk
+ THEN line;
+ putline (" Erst Diskette einlegen !");pause (100)
+ ELIF taste <> " "
+ THEN menue auswerten (stelle)
+ FI;
+ IF is error
+ THEN IF disk
+ THEN melde archiveerror (errormessage)
+ ELSE melde error (errormessage)
+ FI;
+ clear error
+ FI
+ UNTIL taste = "q" PER;
+ IF archiv angemeldet
+ THEN automatische freigabe des archives
+ FI.
+
+ zeige menue:
+ page;
+ write(24 * " "); write(mark ein);
+ write("D A T E I M O N I T O R "); write(mark aus);
+ line(3);
+ zeile ("a","Auflisten aller Dateien in dieser Task");
+ zeile ("l","Loeschen von Dateien in dieser Task");
+ line(2);
+ write( 15 * " ");
+ IF disk
+ THEN write("Archiv: ")
+ ELSE write("Task : ")
+ FI;
+ IF disk
+ THEN IF diskette im schacht
+ THEN IF length(aktueller archivename) > 40
+ THEN write ("'" + subtext (aktueller archivename,1,40) + " ...")
+ ELSE write (invers(""""+ aktueller archivename + """"))
+ FI
+ FI
+ ELSE write (invers("""" + managername + """"))
+ FI;
+ line(2);
+ TEXT VAR zielname 1, zielname 2, zielname 3;
+ IF disk
+ THEN zielname 1 := "des Archivs";
+ zielname 2 := "zum Archiv";
+ zielname 3 := "vom Archiv"
+ ELSE zielname 1 := "in " + managername;
+ zielname 2 := "zu " + managername;
+ zielname 3 := "von " + managername
+ FI;
+ zeile ("u","Uebersicht ueber alle Dateien " + zielname 1);
+ zeile ("s","Senden von Dateien " + zielname 2);
+ zeile ("h","Holen von Dateien " + zielname 3);
+ IF disk
+ THEN zeile ("c","'Checken' von Dateien " + zielname 1)
+ FI;
+ zeile ("v","Vernichten von Dateien " + zielname 1);
+ IF disk THEN
+ zeile ("d","Drucken einer Liste der Dateien des Archivs");
+ zeile ("f","Formatieren einer Diskette");
+ zeile ("i","Initialisieren/vollstaendiges Loeschen des Archivs");
+ zeile ("n","Neue Diskette anmelden");
+ FI;
+ line(1);
+ zeile ("q","Zurueck zum Vormonitor").
+
+END PROC hauptmonitor;
+
+PROC menue auswerten (INT CONST stelle):
+ enable stop;
+ SELECT stelle OF
+ CASE 1 : auflisten der taskdateien
+ CASE 2 : loeschen von dateien in der task
+ CASE 3 : neue diskette anmelden
+ CASE 4 : formatieren einer diskette
+ CASE 5 : initialisieren des archives
+ CASE 6 : (* nichts *)
+ CASE 7 : auflisten der archivedateinamen
+ CASE 8 : schreiben von dateien aufs archive
+ CASE 9 : holen von dateien vom archive
+ CASE 10 : checken von dateien auf dem archive
+ CASE 11 : loeschen von dateien auf dem archive
+ CASE 12 : ausdruck archivelisting
+ END SELECT
+END PROC menue auswerten;
+
+BOOL PROC eingabe von erlaubtem zeichen (TEXT CONST erlaubte zeichen):
+ TEXT VAR char in;
+ char in := getcharety;
+ IF pos (erlaubte zeichen,char in) > 0 AND char in <> " "
+ THEN push (char in);TRUE
+ ELSE FALSE
+ FI.
+END PROC eingabe von erlaubtem zeichen;
+
+PROC zeile (TEXT CONST t,tt):
+ putline (8*" " + ""15"" + t + " "14"" + " ... " + tt)
+END PROC zeile;
+
+PROC formatieren einer diskette:
+ page;
+ putline ("Formatieren einer Diskette.");
+ putline ("===========================");
+ putline (""15"Achtung: Alle Disketten-Informationen werden gelöscht!"14"");
+ line;
+ putline ("Dies sind die moeglichen Formate:");
+ zeile ("o","... Ohne Format-Angabe");
+ zeile ("0","... Standard-Format");
+ zeile ("1","... 40 Spur - 360 KB");
+ zeile ("2","... 80 Spur - 720 KB");
+ zeile ("3","... IBM Std - 1200 KB");
+ zeile ("q","... Es wird nicht formatiert.");
+ TEXT VAR art;
+ put ("Ihre Wahl:");
+ inchar (art, "o01234q");
+ IF art = "q"
+ THEN LEAVE formatieren einer diskette
+ FI;
+ out (art); line;
+ put ("zukünftiger Name des Archives :");
+ editget (aktueller archivename);line;
+ archive (aktueller archivename);
+ diskette im schacht := TRUE;
+ disable stop;
+ IF art = "o" THEN format (archive)
+ ELSE format (int (art), archive)
+ FI;
+ IF is error
+ THEN diskette im schacht := FALSE
+ ELSE aktueller archivename := archiv name
+ FI
+END PROC formatieren einer diskette;
+
+PROC auflisten der taskdateien:
+ DATASPACE VAR dummy ds :: nilspace;
+ FILE VAR f :: sequential file (output,dummy ds);
+ list (f);
+ headline (f,"Liste der eigenen Task");
+ modify (f);
+ to line (f,1);
+ show (f);
+ forget (dummy ds)
+END PROC auflisten der taskdateien;
+
+PROC loeschen von dateien in der task:
+ t1 := invers ("Loeschen von Dateien ") + " Info mit <?>" + trennzeichen +
+ "Bitte alle zu loeschenden Dateien ankreuzen" + trennzeichen +
+ invers ("(Ankreuzen mit <RETURN> )");
+ forget (some (all,t1))
+END PROC loeschen von dateien in der task;
+
+PROC reservieren des archives:
+ TEXT VAR meldung;
+ page;
+ cursor(1,1); write("Bitte warten...");
+ line (2);
+ versuche archive zu reservieren (meldung);
+ IF meldung <> ""
+ THEN page;
+ line(10);
+ write (""15"" + meldung + " "14"");
+ weitermachen;
+ diskette im schacht := FALSE;
+ archive ist meins := FALSE;
+ LEAVE reservieren des archives
+ FI;
+ archive anmelden (aktueller archive name, meldung);
+ IF meldung <> ""
+ THEN melde archiveerror (meldung)
+ FI.
+
+END PROC reservieren des archives;
+
+PROC versuche archive zu reservieren (TEXT VAR fehlermeldung):
+ fehlermeldung := "";
+ IF archive ist meins
+ THEN LEAVE versuche archive zu reservieren
+ FI;
+ disable stop;
+ archive ("");
+ IF is error
+ THEN fehlermeldung := errormessage;
+ archive ist meins := FALSE;
+ clear error;
+ enable stop;
+ ELSE archive ist meins := TRUE;
+ fehlermeldung := "";
+ enable stop
+ FI
+END PROC versuche archive zu reservieren;
+
+PROC archive anmelden (TEXT VAR archivename, fehlermeldung):
+ page;
+ line(3);
+ fehlermeldung := "";
+ IF NOT archive ist meins
+ THEN archivename := "";
+ diskette im schacht := FALSE;
+ fehlermeldung := "nicht reserviert";
+ LEAVE archive anmelden
+ FI;
+ IF yes ("Haben Sie die Diskette eingelegt und das Laufwerk geschlossen")
+ THEN line;
+ write ("Bitte warten...");
+ archive name := archiv name;
+ IF archiv error <> ""
+ THEN fehlermeldung := archiv error;
+ diskette im schacht := FALSE
+ ELSE diskette im schacht := TRUE
+ FI
+ ELSE diskette im schacht := FALSE;
+ archivename := ""
+ FI
+END PROC archive anmelden;
+
+PROC verlange reservierung des archives:
+ page;
+ line(7);
+ write (""15"Sie muessen unbedingt erst das Archiv reservieren, "14"");
+ line(2);
+ write (""15"sonst kann ich nicht darauf zugreifen! "14"");
+ line(2);
+ weitermachen
+END PROC verlange reservierung des archives;
+
+PROC auflisten der archivedateinamen:
+ forget ("Dateiliste", quiet);
+ ueberpruefe reservierung;
+ liste dateien des archivs auf;
+ liste ausgeben;
+ forget ("Dateiliste", quiet).
+
+ ueberpruefe reservierung:
+ IF disk AND diskette im schacht
+ AND NOT archive ist meins
+ THEN verlange reservierung des archives;
+ LEAVE auflisten der archivedateinamen
+ FI.
+
+ liste dateien des archivs auf:
+ FILE VAR f :: sequential file (output,"Dateiliste");
+ disable stop;
+ list(f,manager);
+ IF is error
+ THEN LEAVE auflisten der archivedateinamen;
+ ELSE enable stop
+ FI.
+
+ liste ausgeben:
+ show (f)
+END PROC auflisten der archivedateinamen;
+
+PROC checken von dateien auf dem archive:
+ ueberpruefe reservierung;
+ lasse dateien auswaehlen und checke.
+
+ ueberpruefe reservierung:
+ IF disk AND diskette im schacht
+ AND NOT archive ist meins
+ THEN verlange reservierung des archives;
+ LEAVE checken von dateien auf dem archive
+ FI.
+
+ lasse dateien auswaehlen und checke:
+ t1 := invers ("'Checken' von Dateien (auf dem Archiv) ")
+ + trennzeichen + "Bitte alle zu 'checkenden' Dateien ankreuzen";
+ disable stop;
+ check (some (ALL manager, t1), manager);
+ weitermachen;
+ IF is error
+ THEN LEAVE checken von dateien auf dem archive
+ ELSE enable stop;
+ FI
+END PROC checken von dateien auf dem archive;
+
+PROC schreiben von dateien aufs archive:
+ ueberpruefe reservierung;
+ lasse dateien auswaehlen und schreibe aufs archive.
+
+ueberpruefe reservierung:
+ IF disk AND diskette im schacht
+ AND NOT archive ist meins
+ THEN verlange reservierung des archives;
+ LEAVE schreiben von dateien aufs archive
+ FI.
+
+lasse dateien auswaehlen und schreibe aufs archive:
+ t1 := invers ("Schreiben von Dateien ") + " Info mit <?>" + trennzeichen +
+ "Bitte alle zu schreibenden Dateien ankreuzen." + trennzeichen +
+ invers ("(Ankreuzen mit <RETURN> )");
+ THESAURUS VAR angekreuzte :: some (ALL myself, t1);
+ disable stop;
+ zuerst loeschen;
+ INT VAR zaehler;
+ TEXT VAR dname;
+ page;
+ FOR zaehler FROM 1 UPTO highest entry (angekreuzte) REP
+ IF is error
+ THEN LEAVE schreiben von dateien aufs archive
+ FI;
+ dname := name (angekreuzte, zaehler);
+ IF dname <> ""
+ THEN putline (managername + " <--- """ + dname + """");
+ save (dname, manager)
+ FI;
+ PER.
+
+ zuerst loeschen:
+ IF disk CAND (not empty (angekreuzte))
+ THEN out (center(invers("Bitte Warten"),"-",80));
+ THESAURUS CONST zu loe :: angekreuzte / ALL manager;
+ IF not empty (zu loe) AND NOT is error
+ THEN page;
+ putline ("Zuerst Dateien auf der Diskette loeschen?");
+ erase (zu loe, manager)
+ FI
+ FI
+END PROC schreiben von dateien aufs archive;
+
+BOOL PROC not empty (THESAURUS CONST t):
+ INT VAR i;
+ FOR i FROM 1 UPTO highest entry (t) REP
+ IF name (t,i) <> ""
+ THEN LEAVE not empty WITH TRUE
+ FI
+ PER;
+ FALSE
+END PROC not empty;
+
+PROC holen von dateien vom archive:
+ ueberpruefe reservierung;
+ lasse dateien auswaehlen und hole vom archive.
+
+ueberpruefe reservierung:
+ IF disk AND diskette im schacht
+ AND NOT archive ist meins
+ THEN verlange reservierung des archives;
+ LEAVE holen von dateien vom archive
+ FI.
+
+lasse dateien auswaehlen und hole vom archive:
+ t1 := invers ("Holen von Dateien ") + " Info mit <?>" +
+ trennzeichen +
+ "Bitte alle zu holenden Dateien ankreuzen.";
+ THESAURUS VAR angekreuzte :: some (ALL manager,t1);
+ INT VAR zaehler;
+ TEXT VAR dname;
+ page;
+ FOR zaehler FROM 1 UPTO highest entry (angekreuzte) REP
+ dname := name (angekreuzte, zaehler);
+ disable stop;
+ IF dname <> ""
+ THEN putline (managername + " --> """ + dname + """");
+ fetch (dname, manager)
+ FI;
+ IF is error
+ THEN LEAVE holen von dateien vom archive
+ ELSE enable stop
+ FI
+ PER
+END PROC holen von dateien vom archive;
+
+PROC loeschen von dateien auf dem archive:
+ ueberpruefe reservierung;
+ lasse dateien auswaehlen und loesche.
+
+ ueberpruefe reservierung:
+ IF disk AND diskette im schacht
+ AND NOT archive ist meins
+ THEN verlange reservierung des archives;
+ LEAVE loeschen von dateien auf dem archive
+ FI.
+
+lasse dateien auswaehlen und loesche:
+ t1 := invers ("Vernichten (Loeschen) von Dateien") + " Info mit <?>" +
+ trennzeichen + "Bitte alle zu loeschenden Dateien ankreuzen.";
+ disable stop;
+ erase (some (ALL manager, t1), manager);
+ IF is error
+ THEN LEAVE loeschen von dateien auf dem archive
+ ELSE enable stop;
+ FI
+END PROC loeschen von dateien auf dem archive;
+
+PROC initialisieren des archives:
+ TEXT VAR neuer archivename;
+ page;
+ line(2);
+ write(center (""15"Vollstaendiges Loeschen des Archivs "14""));
+ line(2);
+ IF archive ist meins AND diskette im schacht
+ THEN write("Eingestellter Archivname: " +
+ invers ("""" + aktueller archivename + """"));
+ line(2);
+ IF yes ("Moechten Sie einen anderen Namen fuer das Archiv")
+ THEN line(2);
+ stelle frage nach neuem namen
+ ELSE neuer archivename := aktueller archivename
+ FI
+ ELSE stelle frage nach neuem namen
+ FI;
+ fuehre initialisierung durch.
+
+ stelle frage nach neuem namen:
+ write("Bitte den Namen fuer das Archiv (maximal 30 Buchstaben):");
+ line;
+ getline(neuer archivename);
+ neuer archivename := compress(neuer archivename);
+ IF length (neuer archivename) > 40
+ THEN line(2);
+ write ("Der neue Archivname ist zu lang!");
+ weitermachen;
+ LEAVE initialisieren des archives
+ FI.
+
+ fuehre initialisierung durch:
+ disable stop;
+ aktueller archivename := neuer archivename;
+ archive (neuer archivename);
+ IF is error
+ THEN diskette im schacht := FALSE;
+ archive ist meins := FALSE;
+ LEAVE initialisieren des archives
+ ELSE clear(archive);
+ IF is error
+ THEN diskette im schacht := FALSE;
+ LEAVE initialisieren des archives
+ ELSE aktueller archivename := archiv name;
+ diskette im schacht := archiv error = ""
+ FI
+ FI
+END PROC initialisieren des archives;
+
+PROC ausdruck archivelisting:
+ ueberpruefe reservierung;
+ print archive listing;
+ weitermachen.
+
+ueberpruefe reservierung:
+ IF disk AND diskette im schacht
+ AND NOT archive ist meins
+ THEN verlange reservierung des archives;
+ LEAVE ausdruck archivelisting
+ FI.
+
+print archive listing:
+ FILE VAR listfile := sequential file (output , "PLA");
+ INT VAR i;
+ TEXT CONST head :: 70 * "=",
+ end :: 70 * "_";
+ TEXT VAR record;
+ disable stop;
+ list (listfile, archive);
+ IF is error
+ THEN diskette im schacht := FALSE;
+ LEAVE ausdruck archivelisting
+ FI;
+ print head;
+ erase dummy names;
+ print bottom;
+ print and erase listing.
+
+print head :
+ modify (listfile);
+ to line (listfile, 1);
+ FOR i FROM 1 UPTO 6 REP
+ insert record (listfile)
+ PER;
+ to line (listfile, 1);
+ write record (listfile, type); down (listfile);
+ write record (listfile, head); down (listfile);
+ write record (listfile, "ARCHIVNAME: "+headline (listfile) + " " +
+ time of day +" " + date ); down (listfile);
+ write record (listfile, head); down (listfile);
+ write record (listfile, " "); down (listfile);
+ write record (listfile, "Date Store Contents").
+
+erase dummy names :
+ to line (listfile, 6);
+ WHILE NOT eof (listfile) REP
+ read record (listfile, record);
+ IF (record SUB dummy name pos) = "-"
+ THEN delete record (listfile)
+ ELSE down (listfile)
+ FI
+ PER.
+
+print bottom :
+ output (listfile);
+ putline (listfile, end).
+
+print and erase listing :
+ modify (listfile);
+ edit (listfile);
+ line (3);
+ IF yes ("Archivlisting drucken")
+ THEN print ("PLA")
+ FI;
+ forget ("PLA", quiet).
+
+END PROC ausdruck archivelisting;
+
+PROC neue diskette anmelden:
+ ueberpruefe reservierung;
+ melde neue diskette an.
+
+ ueberpruefe reservierung:
+ IF NOT archive ist meins
+ THEN reservieren des archives;
+ LEAVE neue diskette anmelden
+ FI.
+
+ melde neue diskette an:
+ TEXT VAR meldung;
+ page;
+ cursor(1,1); write("Bitte warten...");
+ line (2);
+ archive anmelden (aktueller archive name,meldung);
+ IF meldung <> ""
+ THEN melde archiveerror (meldung)
+ FI.
+
+END PROC neue diskette anmelden;
+
+PROC automatische freigabe des archives:
+ archive ist meins := FALSE;
+ diskette im schacht := FALSE;
+ command dialogue (FALSE);
+ release(archive);
+ command dialogue (TRUE)
+END PROC automatische freigabe des archives;
+
+PROC melde archiveerror (TEXT CONST meldung):
+ line(2);
+ IF meldung = "nicht reserviert"
+ THEN verlange reservierung des archives;
+ ELIF meldung = "keine diskette"
+ THEN write (""15"Ich mache die Reservierung rueckgaengig! "14"");
+ neu reservieren
+ ELIF pos (meldung,"inkonsistent") > 0
+ THEN write(""15"Diskette ist nicht formatiert / initialisiert "14"");
+ neu reservieren;
+ ELIF pos(meldung,"Lesen unmoeglich") > 0
+ COR pos(meldung, "Schreiben unmoeglich") > 0
+ THEN write(""15"Die Diskette ist falsch eingelegt "14"");line (2);
+ write(""15"oder das Laufwerk ist nicht geschlossen "14"");line (2);
+ write(""15"oder die Diskette ist nicht formatiert !"14"");
+ neu reservieren;
+ ELIF pos (meldung, "Archiv heisst") > 0 AND pos(meldung, "?????") > 0
+ THEN write(""15"Diskette nicht lesbar ! (Name: '?????') "14"");line(2);
+ write(""15"Moeglicherweise ist die Diskette defekt ! "14"");
+ neu reservieren;
+ ELIF pos(meldung, "Archiv heisst") > 0
+ THEN write (invers(meldung));
+ line(2);
+ write (""15"Diskette wurde mit anderem Namen angemeldet!"14"");line(2);
+ write("Bitte neu reservieren!");
+ weitermachen
+ ELSE write(invers(meldung));
+ neu reservieren
+ FI
+END PROC melde archiveerror;
+
+PROC neu reservieren:
+ line (2);
+ write ("Bitte den Fehler beseitigen und das Archiv neu reservieren !");
+ weitermachen;
+ diskette im schacht := FALSE
+END PROC neu reservieren;
+
+PROC weitermachen:
+ line (2);
+ write("Zum Weitermachen bitte irgendeine Taste tippen!");
+ pause
+END PROC weitermachen;
+
+PROC melde error (TEXT CONST meldung):
+ page;
+ line(10);
+ write (invers(meldung));
+ weitermachen
+END PROC melde error
+
+END PACKET mpg dm;
+
+(**************************** TOOLS *******************************)
+
+PACKET mpg tools DEFINES put,
+ th,
+ gen :
+
+
+lernsequenz auf taste legen ("E", ""27""2""27"p"27"qedit ("27"g)"13"");
+
+PROC put (BOOL CONST b) :
+ IF b THEN put ("TRUE") ELSE put ("FALSE") FI
+END PROC put;
+
+PROC th (THESAURUS CONST thes) :
+ THESAURUS VAR help :: SOME thes;help := empty thesaurus
+END PROC th;
+
+(************************ Task - Generierung *******************************)
+
+(* Zum Generieren einer TASK ist folgendes zu beachten:
+
+a) Es muss ein Archiv zur Verfuegung stehen, das einen beliebigen Namen hat.
+b) Auf diesem Archiv muss es eine Datei namens <"gen." + taskname> geben.
+c) Diese Datei muss folgendermassen aufgebaut sein:
+ In jeder Zeile steht genau ein Name einer fuer diese TASK wichtigen Datei.
+ Die ersten Namen sind Namen von zu insertierenden Dateien.
+ Es folgt "gen." + taskname.
+ Alle folgenden Dateinamen werden vom Archiv geholt und bleiben in der
+ TASK erhalten. *)
+
+BOOL VAR archive access :: FALSE;
+
+PROC hole (TEXT CONST dateiname):
+ IF exists (dateiname)
+ THEN display ("***")
+ ELSE IF NOT archive access
+ THEN archiv; (* geaendert BV 10.07.86 *)
+ archive access := TRUE
+ FI;
+ display ("-->");
+ from (dateiname)
+ FI;
+ display (dateiname + ""13""10"")
+END PROC hole;
+
+PROC ins (TEXT CONST dateiname):
+ line;
+ out (77 * "=" + ""13""10"");
+ out (dateiname + " wird insertiert"13""10"");
+ insert (dateiname);
+ forget (dateiname, quiet)
+END PROC ins;
+
+LET anzahl dateien = 50;
+
+ROW anzahl dateien TEXT VAR datei;
+
+INT VAR anzahl zu insertierender,
+ gesamtzahl;
+
+PROC gen:
+ TEXT CONST taskname :: name (myself),
+ gendateiname :: "gen." + taskname;
+ TEXT VAR record;
+ BOOL VAR zu insertieren :: TRUE;
+
+ archive access := FALSE;
+ anzahl zu insertierender := 0;
+ gesamtzahl := 0;
+ page;
+ putline ("GENERIERUNG VON " + taskname);
+ putline ((16 + length (taskname)) * "=");
+ hole (gendateiname);
+
+ FILE VAR gendatei := sequential file (input, gendateiname);
+ WHILE NOT eof (gendatei) AND gesamtzahl < anzahl dateien REP
+ getline (gendatei, record);
+ record := compress (record);
+ IF record = gendateiname
+ THEN zu insertieren := FALSE
+ FI;
+ IF zu insertieren
+ THEN anzahl zu insertierender INCR 1
+ FI;
+ gesamtzahl INCR 1;
+ hole (record);
+ datei [gesamtzahl] := record
+ PER;
+ forget (gendateiname, quiet);
+ IF archive access
+ THEN release;
+ line (2);
+ put ("Bitte entfernen Sie Ihre Diskette aus dem Laufwerk!");
+ line
+ FI;
+ INT VAR i;
+ FOR i FROM 1 UPTO anzahl zu insertierender REP
+ ins (datei [i])
+ PER;
+ IF yes ("global manager")
+ THEN do ("global manager")
+ FI.
+END PROC gen
+
+END PACKET mpg tools;
+
+(********************* MPG TARGET HANDLING *******************)
+
+PACKET target handling DEFINES TARGET,
+ initialize target,
+ complete target,
+ delete in target,
+ select target,
+ actual target name,
+ actual target set,
+ target names:
+
+
+TYPE TARGET = STRUCT (INT ind, THESAURUS target name, target set);
+
+LET no target = 0;
+
+PROC initialize target (TARGET VAR tar):
+ tar.target set := empty thesaurus;
+ tar.target name := empty thesaurus;
+ tar.ind := no target
+END PROC initialize target;
+
+PROC complete target (TARGET VAR tar, TEXT CONST nam, set):
+ IF NOT (tar.target name CONTAINS nam)
+ THEN insert (tar.target name, nam);
+ insert (tar.target set , set)
+ ELSE errorstop ("Bezeichner bereits vorhanden")
+ FI
+END PROC complete target;
+
+PROC delete in target (TARGET VAR tar, TEXT CONST nam):
+ INT CONST ind :: link (tar.target name, nam);
+ delete (tar.target name, ind);
+ delete (tar.target set , ind);
+ tar.ind := no target
+END PROC delete in target;
+
+PROC select target (TARGET VAR tar, TEXT CONST nam, TEXT VAR set):
+ INT VAR ind :: link (tar.target name, nam);
+ IF ind <> 0
+ THEN set := name (tar.target set , ind);
+ tar.ind := ind
+ ELSE set := ""
+ FI
+END PROC select target;
+
+TEXT PROC actual target name (TARGET CONST tar):
+ IF tar.ind = no target
+ THEN ""
+ ELSE name (tar.target name, tar.ind)
+ FI
+END PROC actual target name;
+
+TEXT PROC actual target set (TARGET CONST tar):
+ IF tar.ind = no target
+ THEN ""
+ ELSE name (tar.target set, tar.ind)
+ FI
+END PROC actual target set;
+
+THESAURUS PROC target names (TARGET CONST tar):
+ tar.target name
+END PROC target names
+
+END PACKET target handling;
+
+(*********************** MPG PRINT CMD ***********************)
+
+PACKET mpg print cmd DEFINES print, select printer,
+ install printers,
+ list printers,
+ printer, printers:
+
+
+TARGET VAR printer list;
+
+LET std printer name = "PRINTER",
+ titel = "PRINTER AUSWAHL";
+
+LET trenner = "\#";
+
+TARGET PROC printers:
+ printer list
+END PROC printers;
+
+PROC install printers (FILE VAR f):
+ initialize target (printer list);
+ TEXT VAR nam, set;
+ TEXT VAR std nam :: "", std set :: "";
+ WHILE NOT eof (f) REP
+ TEXT VAR zeile;
+ getline (f, zeile);
+ IF zeile <> ""
+ THEN INT CONST po :: pos (zeile, trenner);
+ nam := subtext (zeile, 1, po - 1);
+ set := subtext (zeile, po + 1);
+ complete target (printer list, nam, set);
+ IF int (nam) = station (myself)
+ THEN std nam := nam;
+ std set := set
+ FI
+ FI
+ PER;
+ select target (printer list, std nam, std set);
+ IF std set <> ""
+ THEN fonttable (std set)
+ FI
+END PROC install printers;
+
+PROC select printer:
+ TEXT VAR font;
+ select target (printer list,
+ one (target names (printer list), titel,1,24), font);
+ IF font <> ""
+ THEN fonttable (font)
+ FI
+END PROC select printer;
+
+PROC list printers:
+ th (target names (printer list))
+END PROC list printers;
+
+PROC print :
+ print (last param)
+END PROC print;
+
+PROC print (TEXT CONST file) :
+ save (file, printer)
+END PROC print;
+
+PROC print (THESAURUS CONST thes) :
+ save (thes, printer)
+END PROC print;
+
+TASK PROC printer:
+ INT VAR stat :: int (actual target name (printer list));
+ IF stat = 0
+ THEN niltask
+ ELSE stat/std printer name
+ FI
+END PROC printer
+
+END PACKET mpg print cmd;
+
+(************************ EDIT MONITOR *************************)
+
+PACKET edit monitor DEFINES edit monitor, (* Lutz Prechelt *)
+ F, (* Carsten Weinholz *)
+ table: (* Thomas Clermont *)
+ (* EUMEL 1.8 *)
+ (* Version 4.4.1 *)
+ (* Multimonitor *)
+ (* Alphaeditor *)
+ (* 06.07.1987 *)
+
+LET command handling line = 18, (* muss > max file + 1 und < 23 sein *)
+ max file = 15, (* max. 20 *)
+ file type = 1003,
+ min lines per segment = 24, (* darunter wird reorganisiert *)
+ integer is allowed = 3,
+ no command = 4711,
+ gib kommando 1 = "Gib Edit-Monitor ",
+ gib kommando 2 = " Kommando :";
+
+TEXT CONST command list ::"quitmonitor:1.0edit:2.1run:3.1insert:4.1" +
+ "forget:5.1rename:6.2copy:7.2fetch:8.1" +
+ "save:9.1close:10.1fileinfo:11.0reorganize:12.1";
+
+LET EDITTABLE = ROW max file STRUCT (THESAURUS line table,
+ TEXT name,
+ FILE file );
+
+LET nil code = 0,
+ edit code= 1,
+ do code = 2;
+
+INT VAR command index, number of params, command indices,
+ aufruftiefe :: 0,zeile;
+
+TEXT VAR param 1, param 2, old command :: "", command line :: "";
+BOOL VAR short command, info :: FALSE,verlasse monitor :: FALSE;
+INITFLAG VAR this monitor;
+
+EDITTABLE VAR etb;
+
+PROC edit monitor :
+ TEXT VAR ch, old lernsequenz :: lernsequenz auf taste ("Q");
+ INT VAR i, previous heap size :: heap size;
+ disable stop;
+ initialize;
+ get new table;
+ REP
+ prepare screen;
+ perhaps reorganize and get command;
+ execute command;
+ collect heap garbage if necessary
+ UNTIL verlasse monitor PER;
+ lernsequenz auf taste legen ("Q",old lernsequenz);
+ close all files if not nested.
+
+initialize :
+ lernsequenz auf taste legen ("Q",""1""8""1""12"quitmonitor"13"");
+ verlasse monitor := FALSE;
+ aufruftiefe INCR 1;
+ IF aufruftiefe > max file
+ THEN aufruftiefe DECR 1;
+ errorstop ("Editmonitor overflow: Bereits " + text (max file ) + "Monitore geoeffnet")
+ ELSE IF NOT initialized (this monitor)
+ THEN FOR i FROM 1 UPTO max file REP
+ etb [i].line table := empty thesaurus;
+ etb [i].name := ""
+ PER
+ FI;
+ FOR i FROM 1 UPTO max file REP
+ etb [i].name := name (etb [aufruftiefe].line table,i)
+ PER
+ FI.
+
+prepare screen :
+ calc command handling line;
+ put file info.
+
+calc command handling line:
+ out (""10""); (* down *)
+ INT VAR dummy, y;
+ get cursor (dummy, y);
+ FOR dummy FROM 1 UPTO y-22 REP
+ out (""10"")
+ PER;
+ zeile := max (command handling line, min (y + 1, 22)).
+
+perhaps reorganize and get command :
+ BOOL VAR anything reorganized :: FALSE,
+ was error :: FALSE ;
+ IF is error
+ THEN command line := old command;
+ out (""3""); (* up *)
+ put error; clear error; was error := TRUE
+ ELSE command line := ""
+ FI;
+ out ( " ");
+ out (gib kommando);
+ out (""13""10" ");
+ IF NOT was error THEN perhaps reorganize FI;
+ IF anything reorganized
+ THEN command index := no command;
+ LEAVE perhaps reorganize and get command
+ FI;
+ editget (command line, "", "fk", ch);
+ IF ch = ""27"k"
+ THEN out (""13""5"");
+ command line := old command;
+ out (" ");
+ editget (command line, "", "f", ch)
+ FI;
+ line;
+ old command := command line;
+ command index := cmd index (command line);
+ param position (LENGTH command line + 7);
+ IF (command index > 0 AND command index <= max file)
+ AND command indices > 0
+ THEN short command := TRUE
+ ELSE short command := FALSE;
+ analyze command (command list, command line, integer is allowed,
+ command index, number of params,param 1, param 2)
+ FI.
+
+perhaps reorganize :
+ BOOL VAR interrupt;
+ ch := getcharety;
+ IF ch <> ""
+ THEN push (ch); LEAVE perhaps reorganize
+ FI;
+ ch := incharety (50);
+ IF ch <> ""
+ THEN type (ch); LEAVE perhaps reorganize
+ FI;
+ FOR i FROM 1 UPTO max file REP
+ reorganize (etb [i].name, anything reorganized, interrupt, i);
+ UNTIL interrupt OR anything reorganized PER.
+
+close all files if not nested :
+ aufruftiefe DECR 1;
+ command index := 0; (* Um die verschachtelten Aufrufe zu schuetzen *)
+ verlasse monitor := aufruftiefe = 0;
+ IF aufruftiefe > 0
+ THEN FOR i FROM 1 UPTO max file REP
+ etb [i].name := name (etb [aufruftiefe].line table,i)
+ PER;
+ ELSE param 1 := "";
+ param 2 := "";
+ command line := "";
+ old command := ""
+ FI.
+
+collect heap garbage if necessary :
+ IF heap size > previous heap size + 4
+ THEN collect heap garbage;
+ previous heap size := heap size
+ FI
+ENDPROC edit monitor;
+
+PROC put file info:
+ INT VAR i;
+ out (""1""); (* home *)
+ FOR i FROM 1 UPTO max file WHILE NOT is incharety REP
+ out (text (i, 2));
+ out (" : ");
+ IF info
+ THEN show file info
+ FI;
+ IF etb [i].name <> ""
+ THEN out ("""" + etb [i].name + """")
+ FI;
+ out (""5""10""13"")
+ PER;
+ out(""5"");
+ cursor (1, zeile).
+
+show file info :
+ (* Falls fileinfo an, werden vor den Dateinamen bei FILEs die Anzahl von
+ Zeilen , Segmenten und Speicher angezeigt. *)
+ IF exists (etb [i].name)
+ THEN IF type (old (etb [i].name)) = file type
+ THEN out (text (lines (etb [i].file), 5));
+ out (" ");
+ out (text (segments (etb [i].file), 4));
+ out (" ")
+ ELSE out ( 11 * "=")
+ FI;
+ out (text (storage (old (etb [i].name)),5))
+ ELIF etb [i].name <> ""
+ THEN out ( 16 * "=")
+ FI;
+ out (" ").
+
+END PROC put file info;
+
+PROC execute command :
+ enable stop;
+ IF command index = no command THEN LEAVE execute command FI;
+ IF short command THEN do edit monitor command (command index)
+ ELSE case selection FI.
+
+case selection :
+ SELECT command index OF
+ CASE 1 : (* quit *) verlasse monitor := TRUE
+ CASE 2 : edit (name from list (param 1))
+ CASE 3 : run (name from list (param 1))
+ CASE 4 : insert (name from list (param 1))
+ CASE 5 : forget (name from list (param 1)); close (int (param1))
+ CASE 6 : rename (name from list (param 1) , name from list (param 2))
+ CASE 7 : copy (name from list (param 1), name from list (param 2))
+ CASE 8 : fetch (name from list (param 1))
+ CASE 9 : save (name from list (param 1))
+ CASE 10: close (int (param 1))
+ CASE 11: info := NOT info
+ CASE 12: reorganize (name from list (param 1))
+ OTHERWISE do (command line)
+ END SELECT
+END PROC execute command;
+
+PROC close (INT CONST n) :
+ IF (n > 0 AND n <= max file) CAND etb [n].name <> ""
+ THEN IF exists (etb [n].name) CAND type (old (etb [n].name)) = file type
+ THEN close (etb [n].file)
+ FI;
+ INT VAR id;
+ delete (etb [aufruftiefe].line table,etb [n].name,id);
+ etb [n].name := ""
+ FI
+END PROC close;
+
+TEXT OP F (INT CONST nr) :
+ IF nr > 0 AND nr <= max file
+ THEN etb [nr].name
+ ELSE out (""7""); ""
+ FI
+END OP F;
+
+OP F (INT CONST nr, TEXT CONST datei) :
+ IF nr > 0 AND nr <= max file
+ THEN etb [nr].name := datei;
+ insert (etb [aufruftiefe].line table,datei);
+ IF exists (datei) CAND type (old (datei)) = file type
+ THEN etb [nr].file := sequential file(modify, datei)
+ FI
+ ELSE out (""7"")
+ FI
+END OP F;
+
+PROC get new table:
+ table (some (all + etb [aufruftiefe].line table + vorgaenger)).
+
+ vorgaenger:
+ IF aufruftiefe = 1
+ THEN empty thesaurus
+ ELSE etb [aufruftiefe - 1].line table
+ FI
+END PROC get new table;
+
+THESAURUS PROC table :
+ THESAURUS VAR result :: emptythesaurus;
+ INT VAR i;
+ FOR i FROM 1 UPTO max file REP
+ IF exists (etb [i].name) AND NOT (result CONTAINS etb [i].name)
+ THEN insert (result, etb [i].name)
+ FI
+ PER;
+ result
+END PROC table;
+
+PROC table (THESAURUS CONST new) :
+ INT VAR i, nr :: 1, dummy;
+ TEXT VAR t;
+ etb [aufruftiefe].line table := empty thesaurus;
+ FOR i FROM 1 UPTO max file REP
+ etb [i].name := ""
+ PER;
+ FOR i FROM 1 UPTO highest entry (new) REP
+ get (new, t, dummy);
+ IF t <> ""
+ THEN nr F t;nr INCR 1
+ FI
+ UNTIL nr > max file PER
+END PROC table;
+
+PROC do edit monitor command (INT CONST file nr) :
+ enable stop;
+ IF command indices = 1
+ THEN try to edit or to execute
+ ELSE try alpha editor
+ FI.
+
+try to edit or to execute:
+ SELECT prepare edit (file nr) OF
+ CASE edit code: last param (etb [file nr].name);
+ edit (etb [file nr].file);
+ page
+ CASE do code : do (etb[file nr].name)
+ END SELECT.
+
+try alpha editor:
+ IF command indices <= 10
+ THEN open sub editors;
+ IF groesster editor > 0
+ THEN edit (1);
+ WHILE groesster editor > 0 REP
+ quit
+ PER;
+ page
+ FI
+ ELSE errorstop ("Maximal 10 Parallel-Editoren")
+ FI.
+
+open sub editors:
+ TEXT VAR num, edit cmd :: "";
+ INT VAR ye :: 1, sub :: file nr, pass;
+ WHILE groesster editor > 0 REP
+ quit
+ PER;
+ FOR pass FROM 1 UPTO 2 REP
+ IF pass = 2
+ THEN command line := edit cmd
+ FI;
+ scan (command line);
+ next symbol (num); (* skip ersten index *)
+ REP
+ INT VAR op code := prepare edit (sub);
+ IF pass = 1
+ THEN SELECT op code OF
+ CASE nil code : command indices DECR 1
+ CASE editcode : edit cmd CAT (num + " ")
+ CASE do code : edit cmd CAT (num + " ");
+ command indices DECR 1
+ END SELECT
+ ELSE SELECT op code OF
+ CASE edit code: neuer editor
+ CASE do code: do (etb [sub].name);
+ IF groesster editor > 0
+ THEN bild zeigen;
+ ueberschrift zeigen
+ FI
+ END SELECT
+ FI;
+ next symbol (num);
+ sub := int (num)
+ UNTIL num = "" PER;
+ sub := file nr;
+ PER.
+
+ neuer editor:
+ open editor (groesster editor+1,etb [sub].file, TRUE, 1,ye,79,25-ye);
+ ye INCR (24 DIV command indices)
+
+END PROC do edit monitor command;
+
+INT PROC prepare edit (INT CONST file nr):
+ IF file nr > 0 AND file nr <= max file
+ THEN IF etb [file nr].name = ""
+ THEN get file name and open;
+ IF etb [file nr].name <> ""
+ THEN IF exists (etb [file nr].name)
+ THEN IF type (old (etb [file nr].name)) = file type
+ THEN edit code
+ ELSE nil code
+ FI
+ ELSE do code
+ FI
+ ELSE nil code
+ FI
+ ELIF NOT exists (etb [file nr].name)
+ THEN do code
+ ELIF type (old (etb [file nr].name)) <> file type
+ THEN nil code
+ ELSE modify (etb [file nr].file);
+ edit code
+ FI
+ ELSE errorstop ("Undefinierter Index [1;15]");nil code
+ FI.
+
+get file name and open :
+ cursor (4, file nr);
+ out (""5"? ");
+ editget (etb [file nr].name);
+ IF etb [file nr].name <> ""
+ THEN file nr F etb [file nr].name;
+ IF NOT exists (etb [file nr].name)
+ THEN out (""13""10"");
+ IF no (5 * ""2"" +"Datei neu einrichten")
+ THEN LEAVE prepare edit WITH nil code
+ ELSE kopple file an
+ FI
+ ELIF type (old (etb [file nr].name)) = file type
+ THEN kopple file an
+ FI
+ FI.
+
+ kopple file an:
+ etb [file nr].file := sequential file (output, etb [file nr].name).
+
+END PROC prepare edit;
+
+(***************** Hilfsprozeduren *********************************)
+
+BOOL PROC is incharety :
+ TEXT VAR ch :: getcharety;
+ IF ch = ""
+ THEN FALSE
+ ELSE push (ch);
+ TRUE
+ FI
+END PROC is incharety;
+
+TEXT PROC name from list (TEXT CONST name):
+ INT VAR i :: int (name);
+ IF (i > 0 AND i <= max file)
+ THEN etb [i].name
+ ELSE name
+ FI.
+END PROC name from list;
+
+PROC reorganize (TEXT CONST datei, BOOL VAR reorganization processed,
+ interrupted,
+ INT CONST file nummer):
+ (* Reorganisiert nur , falls :
+ 1. Datei ein FILE ist
+ 2. FILE mindestens "min lines to reorganize" Zeilen hat
+ 3. FILE nicht im Schnitt "min lines per segment" Zeilen pro Segment hat
+ 4. kein Tastendruck erfolgt
+ *)
+ DATASPACE VAR ds;
+ FILE VAR in, out;
+ TEXT VAR t;
+ INT VAR actual line,i,x,y;
+ get cursor (x,y);
+ interrupted := FALSE;
+ IF NOT exists (datei) COR type (old (datei)) <> file type
+ THEN LEAVE reorganize
+ FI;
+ in := sequential file (modify, datei);
+ actual line := line no (in);
+ input (in);
+ IF (lines (in) < 120 CAND segments (in) < 6) COR
+ lines (in) DIV segments (in) >= min lines per segment
+ THEN modify (in);
+ to line (in,actual line);
+ LEAVE reorganize
+ FI;
+ disable stop;
+ ds := nilspace;
+ out := sequential file (output, ds);
+ IF info
+ THEN FOR i FROM 1 UPTO lines (in) REP
+ cursor (4, file nummer);
+ put (i);
+ getline (in, t);
+ putline (out, t);
+ IF is error COR is incharety THEN interrupt FI
+ PER
+ ELSE FOR i FROM 1 UPTO lines (in) REP
+ getline (in, t);
+ putline (out, t);
+ IF is error COR is incharety THEN interrupt FI
+ PER
+ FI;
+ copy attributes (in,out);
+ modify (out);
+ to line (out,actual line);
+ forget (datei, quiet);
+ copy (ds, datei);
+ forget (ds);
+ reorganization processed := TRUE.
+
+interrupt :
+ cursor (4, lines (in));
+ forget (ds);
+ interrupted := TRUE;
+ cursor (x,y);
+ enable stop;
+ LEAVE reorganize.
+
+END PROC reorganize;
+
+INT PROC cmd index (TEXT CONST command line):
+ INT VAR type, result :: 0;
+ TEXT VAR num;
+ command indices := 0;
+ scan (command line);
+ REP
+ next symbol (num, type);
+ IF type = 3 (* Ziffernfolge *)
+ THEN IF command indices = 0
+ THEN result := int (num)
+ FI;
+ command indices INCR 1
+ ELIF type <> 7
+ THEN command indices := 0
+ FI
+ UNTIL type = 7 OR command indices = 0 PER;
+ result
+END PROC cmd index;
+
+TEXT PROC gib kommando:
+ gib kommando 1 + text (aufruftiefe) + gib kommando 2
+END PROC gib kommando;
+
+END PACKET edit monitor;
+
+(******************************** MANAGER ******************************)
+
+PACKET mpg global manager DEFINES monitor,
+ break,
+ end global manager,
+ begin,
+ begin password,
+ manager message,
+ manager question,
+ free manager,
+ std manager,
+ mpg manager,
+ free global manager,
+ global manager :
+
+
+LET ack = 0,
+ nak = 1,
+ error nak = 2,
+ message ack = 3,
+ question ack = 4,
+ second phase ack = 5,
+ false code = 6,
+
+ begin code = 4,
+ password code = 9,
+ fetch code = 11,
+ save code = 12,
+ exists code = 13,
+ erase code = 14,
+ list code = 15,
+ all code = 17,
+
+ killer code = 24,
+
+ continue code = 100,
+
+ error pre = ""7""13""10""5"Fehler : ",
+ cr lf = ""13""10"";
+
+
+DATASPACE VAR ds := nilspace;
+
+BOUND STRUCT (TEXT fnam, write pass, read pass) VAR msg;
+BOUND TEXT VAR reply msg;
+
+TASK VAR order task, last order task;
+
+FILE VAR list file;
+INT VAR reply, order, last order, phase no;
+TEXT VAR error message buffer :: "",
+ record,
+ fnam,
+ create son password :: "",
+ save write password,
+ save read password,
+ save file fnam;
+
+TEXT VAR std begin proc :: "checkoff;endglobalmanager(TRUE);" +
+ "warnings off;sysout("""");sysin("""");" +
+ "monitor";
+BOOL VAR is global manager, is break manager;
+
+PROC mpg manager (PROC (DATASPACE VAR, INT CONST, INT CONST, TASK CONST)
+ manager) :
+ IF online
+ THEN TEXT VAR dummy;
+ put ("Task-Passwort :");
+ getsecretline (dummy);
+ IF dummy <> "" THEN taskpassword (dummy) FI;
+ put ("Beginn-Passwort:");
+ getsecretline (dummy);
+ IF dummy <> "" THEN begin password (dummy) FI
+ FI;
+ is break manager := FALSE;
+ global manager (PROC (DATASPACE VAR, INT CONST, INT CONST, TASK CONST)
+ manager)
+END PROC mpg manager;
+
+PROC global manager :
+ mpg manager (PROC (DATASPACE VAR, INT CONST, INT CONST, TASK CONST)
+ std manager)
+END PROC global manager;
+
+PROC global manager (PROC (DATASPACE VAR, INT CONST, INT CONST,
+ TASK CONST) manager) :
+ is global manager := TRUE;
+ internal manager (PROC (DATASPACE VAR,INT CONST,INT CONST,
+ TASK CONST) manager)
+END PROC global manager;
+
+PROC internal manager (PROC (DATASPACE VAR, INT CONST, INT CONST,
+ TASK CONST) manager) :
+ old break;
+ set autonom;
+ disable stop;
+ command dialogue (FALSE);
+ last order task := niltask;
+ remember heap size;
+ REP
+ wait (ds, order, order task);
+ IF order <> second phase ack
+ THEN prepare first phase;
+ manager (ds, order, phase no, order task)
+ ELIF order task = last order task
+ THEN prepare second phase;
+ manager (ds, order, phase no, order task)
+ ELSE send nak FI;
+ send error if necessary;
+ collect heap garbage if necessary
+ UNTIL (NOT is global manager) AND (NOT is break manager)
+ PER;
+ command dialogue (TRUE);
+ reset autonom.
+
+send error if necessary :
+ IF is error
+ THEN forget (ds);
+ ds := nilspace;
+ reply msg := ds;
+ CONCR (reply msg) := error message;
+ clear error;
+ send (order task, error nak, ds)
+ FI .
+
+remember heap size :
+ INT VAR old heap size := heap size .
+
+collect heap garbage if necessary :
+ IF heap size > old heap size + 2
+ THEN collect heap garbage;
+ old heap size := heap size
+ FI .
+
+prepare first phase :
+ phase no := 1;
+ last order := order;
+ last order task := order task.
+
+prepare second phase :
+ phase no INCR 1;
+ order := last order.
+
+send nak :
+ forget (ds);
+ ds := nilspace;
+ send (order task, nak, ds)
+END PROC internal manager;
+
+PROC free global manager :
+ mpg manager (PROC (DATASPACE VAR, INT CONST, INT CONST, TASK CONST)
+ free manager)
+END PROC free global manager;
+
+PROC std manager (DATASPACE VAR ds, INT CONST order, phase,
+ TASK CONST order task) :
+ IF (order = begin code AND task darf beginnen) COR
+ task darf senden
+ THEN free manager (ds, order, phase, order task)
+ ELSE errorstop ("Kein Zugriffsrecht auf Task """ + name (myself) + """")
+ FI.
+
+ task darf beginnen:
+ (task ist systemtask OR task ist sohn) AND is global manager.
+
+ task darf senden:
+ task ist systemtask OR task ist sohn.
+
+ task ist systemtask:
+ ordertask < supervisor OR ordertask = supervisor.
+
+ task ist sohn:
+ order task < myself
+END PROC std manager;
+
+PROC free manager (DATASPACE VAR ds, INT CONST order, phase,
+ TASK CONST order task) :
+ enable stop;
+ IF order > continue code AND
+ order task = supervisor THEN y maintenance
+ ELIF order = begin code AND is global manager
+ THEN y begin
+ ELSE file manager order
+ FI .
+
+file manager order :
+ get message text if there is one;
+ SELECT order OF
+ CASE fetch code : y fetch
+ CASE save code : y save
+ CASE exists code : y exists
+ CASE erase code : y erase
+ CASE list code : y list
+ CASE all code : y all
+ CASE killer code : y killer
+ OTHERWISE errorstop ("Falscher Auftrag fuer Task """ + name (myself) + """")
+ ENDSELECT .
+
+get message text if there is one :
+ IF order >= fetch code AND order <= erase code AND phase = 1 (* 28.6.'86 *)
+ THEN msg := ds;
+ fnam := msg.fnam
+ FI .
+
+y begin :
+ BOUND STRUCT (TEXT tname, tpass, TASK task, PROCA start proc) VAR sv msg := ds;
+ IF create son password = sv msg.tpass AND create son password <> "-"
+ THEN create son task
+ ELIF sv msg.tpass = ""
+ THEN ask for password
+ ELSE errorstop ("Passwort falsch")
+ FI .
+
+create son task :
+ begin (ds, PROC std begin, reply);
+ send (order task, reply, ds) .
+
+ask for password :
+ send (order task, password code, ds) .
+
+y fetch :
+ IF read permission (fnam, msg.read pass) COR order task < supervisor
+ THEN forget (ds);
+ ds := old (fnam);
+ send (order task, ack, ds)
+ ELSE errorstop ("Passwort falsch")
+ FI .
+
+y erase :
+ msg := ds;
+ fnam := msg.fnam;
+ IF NOT exists (fnam)
+ THEN manager message ("""" + fnam + """ existiert nicht", order task)
+ ELIF phase no = 1
+ THEN manager question ("""" + fnam + """ loeschen", order task)
+ ELIF write permission (fnam, msg.write pass) COR order task < supervisor
+ THEN forget (fnam, quiet);
+ send (order task, ack, ds)
+ ELSE errorstop ("Passwort falsch") FI .
+
+y save :
+ IF phase no = 1
+ THEN ysave pre
+ ELSE y save post FI.
+
+y save pre :
+ IF write permission (fnam, msg.write pass) COR order task < supervisor
+ THEN save file fnam := fnam;
+ save write password := msg.write pass;
+ save read password := msg.read pass;
+ IF exists (fnam)
+ THEN manager question (""""+fnam+""" ueberschreiben", order task)
+ ELSE send (order task, second phase ack, ds)
+ FI;
+ ELSE errorstop ("Passwort falsch")
+ FI .
+
+y save post :
+ forget (save file fnam, quiet);
+ copy (ds, save file fnam);
+ enter password (save file fnam,
+ save write password, save read password);
+ forget (ds);
+ ds := nilspace;
+ send (order task, ack, ds);
+ cover tracks of save passwords.
+
+cover tracks of save passwords :
+ replace (save write password, 1, LENGTH save write password * " ");
+ replace (save read password, 1, LENGTH save read password * " ") .
+
+y exists :
+ IF exists (fnam)
+ THEN send (order task, ack, ds)
+ ELSE send (order task, false code, ds)
+ FI.
+
+y list :
+ forget (ds);
+ ds := nilspace;
+ list file := sequential file (output, ds);
+ list (list file);
+ send (order task, ack, ds) .
+
+y all :
+ BOUND THESAURUS VAR all fnams := ds;
+ all fnams := all;
+ send (order task, ack, ds) .
+
+y maintenance :
+ TEXT VAR param 1, param 2;
+ INT VAR c index, nr of params;
+ TEXT CONST c list :: "break:1.0end:2.0monitor:3.0stdbeginproc:4.1";
+ disable stop;
+ call (supervisor, order, ds, reply);
+ forget (ds);
+ IF reply = ack
+ THEN IF is break manager
+ THEN end global manager (TRUE);
+ LEAVE y maintenance
+ FI;
+ put error message if there is one;
+ REP
+ command dialogue (TRUE);
+ get command ("Gib " + name (myself) + "-Kommando :");
+ analyze command (c list,0,c index,nr of params,param 1,param 2);
+ SELECT c index OF
+ CASE 1 : old break
+ CASE 2, 3 : is global manager := FALSE;
+ is break manager := FALSE;
+ LEAVE y maintenance
+ CASE 4 : std begin proc := param 1
+ OTHERWISE do command
+ END SELECT
+ UNTIL NOT on line PER;
+ command dialogue (FALSE);
+ old break;
+ set autonom;
+ save error message if there is one
+ FI;
+ enable stop .
+
+put error message if there is one :
+ IF error message buffer <> ""
+ THEN out (error pre);
+ out (error message buffer);
+ out (cr lf);
+ error message buffer := ""
+ FI.
+
+save error message if there is one :
+ IF is error
+ THEN error message buffer := error message;
+ clear error
+ FI.
+
+y killer :
+ FILE VAR f :: sequential file (input, ds);
+ WHILE NOT eof (f) REP
+ getline (f, record);
+ IF exists (record) THEN forget (record, quiet) FI
+ PER;
+ send (order task, ack, ds).
+ENDPROC free manager;
+
+PROC manager question (TEXT CONST question) :
+ forget (ds);
+ ds := nilspace;
+ reply msg := ds;
+ reply msg := question;
+ send (order task, question ack, ds)
+END PROC manager question;
+
+PROC manager question (TEXT CONST question, TASK CONST receiver) :
+ forget (ds);
+ ds := nilspace;
+ reply msg := ds;
+ reply msg := question;
+ send (receiver, question ack, ds)
+END PROC manager question;
+
+PROC manager message (TEXT CONST message) :
+ forget (ds);
+ ds := nilspace;
+ reply msg := ds;
+ reply msg := message;
+ send (order task, message ack, ds)
+END PROC manager message;
+
+PROC manager message (TEXT CONST message, TASK CONST receiver) :
+ forget (ds);
+ ds := nilspace;
+ reply msg := ds;
+ reply msg := message;
+ send (receiver, message ack, ds)
+END PROC manager message;
+
+PROC std begin :
+ do (std begin proc)
+ENDPROC std begin;
+
+PROC begin (TEXT CONST task name) :
+ TASK VAR sohn;
+ begin (task name, PROC monitor, sohn)
+END PROC begin;
+
+PROC begin password (TEXT CONST password) :
+ cover tracks of old create son password;
+ create son password := password;
+ display (""3""13""5"");
+ cover tracks.
+
+cover tracks of old create son password:
+ replace (create son password,1,LENGTH create son password * " ")
+END PROC begin password;
+
+PROC end global manager (BOOL CONST ende) :
+ is global manager := NOT ende;
+ is break manager := NOT ende
+ENDPROC end global manager;
+
+PROC old break :
+ eumel must advertise;
+ supervisor call (6)
+END PROC old break;
+
+PROC break :
+ IF is global manager
+ THEN old break; LEAVE break
+ FI;
+ is break manager := TRUE;
+ is global manager := FALSE;
+ internal manager (PROC (DATASPACE VAR, INT CONST, INT CONST, TASK CONST)
+ std manager)
+END PROC break;
+
+PROC supervisor call (INT CONST nr) :
+ DATASPACE VAR sv space :: nilspace;
+ INT VAR answer;
+ call (supervisor, nr, sv space, answer);
+ IF answer = error nak
+ THEN BOUND TEXT VAR err msg :: sv space;
+ forget (sv space); errorstop (err msg)
+ FI;
+ forget (sv space)
+END PROC supervisor call;
+
+
+
+LET cmd list =
+
+"edit:1.01end:3.0run:4.01runagain:6.0insert:7.01forget:9.01rename:11.2copy:12.2
+list:13.0storageinfo:14.0taskinfo:15.0fetch:16.1save:17.01saveall:19.0";
+
+
+INT VAR cmd index , params , previous heap size ;
+TEXT VAR param1, param2 ;
+
+
+PROC monitor :
+ disable stop ;
+ previous heap size := heap size ;
+ REP
+ command dialogue (TRUE);
+ sysin ("");
+ sysout ("");
+ cry if not enough storage;
+ get command ("gib kommando :");
+ analyze command (cmd list, 4, cmd index, params, param1, param2);
+ execute command ;
+ collect heap garbage if necessary
+ PER .
+
+collect heap garbage if necessary :
+ IF heap size > previous heap size + 4
+ THEN collect heap garbage ;
+ previous heap size := heap size
+ FI.
+
+cry if not enough storage :
+ INT VAR size, used;
+ storage (size, used);
+ IF used > size
+ THEN out (""7"Speicher Engpass! Dateien loeschen!"13""10"")
+ FI.
+ENDPROC monitor ;
+
+PROC execute command :
+ enable stop ;
+ SELECT cmd index OF
+ CASE 1 : edit
+ CASE 2 : edit (param1)
+ CASE 3 : end
+ CASE 4 : run
+ CASE 5 : run (param1)
+ CASE 6 : run again
+ CASE 7 : insert
+ CASE 8 : insert (param1)
+ CASE 9 : forget
+ CASE 10: forget (param1)
+ CASE 11: rename (param1, param2)
+ CASE 12: copy (param1, param2)
+ CASE 13: list
+ CASE 14: storage info
+ CASE 15: task info
+ CASE 16: fetch (param1)
+ CASE 17: save
+ CASE 18: save (param1)
+ CASE 19: save all
+ OTHERWISE do command
+ ENDSELECT .
+
+ENDPROC execute command ;
+
+END PACKET mpg global manager
+