From 04e68443040c7abad84d66477e98f93bed701760 Mon Sep 17 00:00:00 2001 From: Lars-Dominik Braun Date: Mon, 4 Feb 2019 13:09:03 +0100 Subject: Initial import --- app/mpg/2.2/src/PUBLIC.insert | 3412 +++++++++++++++++++++++++++++++++++++++++ 1 file changed, 3412 insertions(+) create mode 100644 app/mpg/2.2/src/PUBLIC.insert (limited to 'app/mpg/2.2/src/PUBLIC.insert') 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 )"); + 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 )"); + 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 + -- cgit v1.2.3