diff options
Diffstat (limited to 'app/eudas/4.4/src/eudas.verarbeitung')
| -rw-r--r-- | app/eudas/4.4/src/eudas.verarbeitung | 731 |
1 files changed, 731 insertions, 0 deletions
diff --git a/app/eudas/4.4/src/eudas.verarbeitung b/app/eudas/4.4/src/eudas.verarbeitung new file mode 100644 index 0000000..95af7cc --- /dev/null +++ b/app/eudas/4.4/src/eudas.verarbeitung @@ -0,0 +1,731 @@ +PACKET verarbeitung + +(*************************************************************************) +(* *) +(* Automatische Verarbeitung von EUDAS-Dateien *) +(* *) +(* Version 05 *) +(* *) +(* Autor: Thomas Berlage *) +(* Stand: 17.04.87 *) +(* *) +(*************************************************************************) + + DEFINES + + kopiere, + std kopiermuster, + verarbeite, + trage, + eindeutige felder, + pruefe, + wertemenge, + feldmaske, + trage satz, + hole satz, + K, + V, + f, + wert, + zahltext, + textdarstellung : + + +SATZ VAR + zielfeldnamen, + kopierfeldnamen, + kopiersatz; + +INT VAR kopierindex; + +BOOL VAR erstes mal; + +LET + niltext = "", + INTVEC = TEXT; + +INTVEC VAR kopiervektor; + +TEXT VAR zwei bytes := " "; + + +OP CAT (INTVEC VAR intvec, INT CONST zahl) : + + replace (zwei bytes, 1, zahl); + intvec CAT zwei bytes + +END OP CAT; + +PROC std kopiermuster (TEXT CONST dateiname, FILE VAR kopiermuster) : + + teste ob datei vorhanden; + INT VAR zielfelder; + dateien oeffnen; + feldnamen bestimmen; + INT VAR feldnr; + FOR feldnr FROM 1 UPTO zielfelder REP + feldnamen auslesen; + IF feld vorhanden THEN + direkt kopieren + ELSE + leer kopieren + END IF + END REP . + +dateien oeffnen : + output (kopiermuster); + EUDAT VAR eudas datei; + IF exists (dateiname) THEN + oeffne (eudas datei, dateiname) + END IF . + +feldnamen bestimmen : + IF exists (dateiname) CAND felderzahl (eudas datei) > 0 THEN + feldnamen lesen (eudas datei, zielfeldnamen); + zielfelder := felderzahl (eudas datei) + ELSE + quellfeldnamen kopieren; + zielfelder := anzahl felder + END IF . + +quellfeldnamen kopieren : + TEXT VAR feldname; + satz initialisieren (zielfeldnamen); + FOR feldnr FROM 1 UPTO anzahl felder REP + feldnamen lesen (feldnr, feldname); + feld aendern (zielfeldnamen, feldnr, feldname) + END REP . + +feld vorhanden : + feldnummer (feldname) > 0 . + +feldnamen auslesen : + feld lesen (zielfeldnamen, feldnr, feldname); + put (kopiermuster, textdarstellung (feldname)) . + +direkt kopieren : + write (kopiermuster, "K f("); + write (kopiermuster, textdarstellung (feldname)); + putline (kopiermuster, ");") . + +leer kopieren : + putline (kopiermuster, "K """";") . + +END PROC std kopiermuster; + +PROC kopiere (TEXT CONST dateiname, FILE VAR kopiermuster) : + + programmfunktion (kopieraufruf, kopiermuster) . + +kopieraufruf : + "kopiere (" + textdarstellung (dateiname) + ", " . + +END PROC kopiere; + +PROC programmfunktion (TEXT CONST aufruf, FILE VAR muster) : + + programmdatei einrichten; + write (programm, aufruf); + putline (programm, "PROC programmfunktion);"); + putline (programm, "PROC programmfunktion:"); + muster kopieren; + putline (programm, "END PROC programmfunktion"); + programm ausfuehren; + forget (programm datei, quiet) . + +programmdatei einrichten : + TEXT VAR programmdatei; + INT VAR i := 0; + REP + i INCR 1; + programmdatei := text (i) + UNTIL NOT exists (programmdatei) END REP; + disable stop; + FILE VAR programm := sequential file (output, programm datei); + headline (programm, erzeugtes programm) . + +muster kopieren : + TEXT VAR zeile; + input (muster); + WHILE NOT eof (muster) REP + getline (muster, zeile); + putline (programm, zeile) + END REP . + +programm ausfuehren : + TEXT CONST alter last param := std; + run (programmdatei); + last param (alter last param) . + +END PROC programm funktion; + +PROC kopiere (TEXT CONST dateiname, PROC kopierfunktion) : + + enable stop; + INT VAR modus; + auf ersten satz (modus); + IF dateiende THEN + auf satz (1); + LEAVE kopiere + ELSE + zieldatei einrichten + END IF; + + WHILE NOT dateiende REP + satz initialisieren (kopiersatz); + kopierindex := 1; + kopierfunktion; + evtl feldnamen einrichten; + satz einfuegen (eudas datei, kopiersatz); + weiter (eudas datei); + weiter (modus) + END REP; + auf satz (1) . + +zieldatei einrichten : + erstes mal := TRUE; + EUDAT VAR eudas datei; + oeffne (eudas datei, dateiname); + auf satz (eudas datei, saetze (eudas datei) + 1); + feldnamen lesen (eudas datei, kopierfeldnamen); + kopiervektor := niltext . + +evtl feldnamen einrichten : + IF erstes mal THEN + feldnamen aendern (eudas datei, kopierfeldnamen); + erstes mal := FALSE + END IF + +END PROC kopiere; + +OP K (TEXT CONST feldname, ausdruck) : + + IF erstes mal THEN + kopiervektor erstellen; + END IF; + feld aendern (kopiersatz, kopiervektor ISUB kopierindex, ausdruck); + kopierindex INCR 1 . + +kopiervektor erstellen : + INT VAR aktueller index := feldindex (kopierfeldnamen, feldname); + IF aktueller index = 0 THEN + aktueller index := felderzahl (kopierfeldnamen) + 1; + feld aendern (kopierfeldnamen, aktueller index, feldname); + END IF; + kopiervektor CAT aktueller index . + +END OP K; + +PROC verarbeite (FILE VAR verarbeitungsmuster) : + + programmfunktion ("verarbeite (", verarbeitungsmuster) + +END PROC verarbeite; + +PROC verarbeite (PROC verarbeitungsfunktion) : + + enable stop; + INT VAR modus; + auf ersten satz (modus); + + WHILE NOT dateiende REP + verarbeitungsfunktion; + weiter (modus) + END REP; + auf satz (1) + +END PROC verarbeite; + +OP V (TEXT CONST feldname, ausdruck) : + + INT CONST nr := feldnummer (feldname); + IF nr = 0 THEN + unbekannt (feldname) + ELSE + feld aendern (nr, ausdruck) + END IF + +END OP V; + +PROC auf ersten satz (INT VAR modus) : + + teste ob datei vorhanden; + auf satz (1); + IF markierte saetze > 0 THEN + modus := 3; + IF NOT satz markiert THEN weiter (modus) END IF + ELSE + modus := 2; + IF NOT satz ausgewaehlt THEN weiter (modus) END IF + END IF + +END PROC auf ersten satz; + +PROC teste ob datei vorhanden : + + IF anzahl dateien = 0 THEN + errorstop (keine datei geoeffnet) + END IF . + +END PROC teste ob datei vorhanden; + + +(******************************** Zugriffe *******************************) + +TEXT VAR + feldpuffer, + werttext; + +LET quote = """"; + + +TEXT PROC f (TEXT CONST feldname) : + + INT CONST nr := feldnummer (feldname); + IF nr = 0 THEN + unbekannt (feldname); + feldpuffer := niltext + ELSE + feld lesen (nr, feldpuffer) + END IF; + feldpuffer + +END PROC f; + +REAL PROC wert (TEXT CONST feldname) : + + INT CONST nr := feldnummer (feldname); + IF nr = 0 THEN + unbekannt (feldname); + 0.0 + ELSE + feld lesen (nr, feldpuffer); + REAL VAR ergebnis; + wert berechnen (feldpuffer, ergebnis); + ergebnis + END IF + +END PROC wert; + +REAL PROC wert (TEXT CONST feldname, INT CONST kommastellen) : + + round (wert (feldname), kommastellen) + +END PROC wert; + +TEXT PROC zahltext (REAL CONST feldwert, INT CONST kommastellen) : + + REAL CONST w := round (abs (feldwert), kommastellen); + INT VAR stellen := exponent der zahl + kommastellen + 2; + IF feldwert < 0.0 THEN + werttext := "-" + ELSE + werttext := niltext + END IF; + IF w < 1.0 AND w <> 0.0 THEN + werttext CAT "0"; + stellen DECR 1 + ENDIF; + werttext CAT text (w, stellen, kommastellen); + IF kommastellen > 0 THEN + change (werttext, ".", dezimalkomma) + ELSE + change (werttext, ".", niltext) + END IF; + werttext . + +exponent der zahl : + max (0, decimal exponent (w)) . + +END PROC zahltext; + +TEXT PROC zahltext (TEXT CONST feldname, INT CONST kommastellen) : + + zahltext (wert (feldname), kommastellen) + +END PROC zahltext; + +TEXT PROC textdarstellung (TEXT CONST anzeigetext) : + + feldpuffer := anzeigetext; + change all (feldpuffer, quote, quote + quote); + steuerzeichen umwandeln; + insert char (feldpuffer, quote, 1); + feldpuffer CAT quote; + feldpuffer . + +steuerzeichen umwandeln : + INT VAR stelle := 1; + WHILE steuerzeichen vorhanden REP + change (feldpuffer, stelle, stelle, steuertext) + END REP . + +steuerzeichen vorhanden : + stelle := pos (feldpuffer, ""0"", ""31"", stelle); + stelle > 0 . + +steuertext : + quote + text (code (feldpuffer SUB stelle)) + quote . + +END PROC textdarstellung; + +PROC unbekannt (TEXT CONST feldname) : + + errorstop (t das feld + textdarstellung (feldname) + + nicht definiert) + +END PROC unbekannt; + + +(****************************** Tragen ***********************************) + +SATZ VAR tragsatz; + +EUDAT VAR zieldatei; + +LET + erzeugtes programm = #501# + "erzeugtes Programm", + keine datei geoeffnet = #502# + "keine Datei geoeffnet", + kein satz vorhanden = #503# + "Kein Satz zum Tragen vorhanden", + falsche felderzahl = #504# + "Zieldatei hat falsche Felderzahl", + existiert nicht = #505# + " existiert nicht", + verletzt die pruefbedingung = #506# + " verletzt die Pruefbedingung.", + bereits vorhanden = #507# + " ist in der Zieldatei bereits vorhanden.", + nicht definiert = #508# + " ist nicht definiert.", + nicht in wertemenge = #509# + " ist nicht in der Wertemenge.", + passt nicht zu maske = #510# + " stimmt nicht mit der Maske ueberein.", + t satz = #511# + "Satz ", + t das feld = #512# + "Das Feld "; + +INT VAR + anzahl eindeutiger felder; + +FILE VAR protokoll; + +BOOL VAR + testen := FALSE, + test erfolgreich, + uebereinstimmung; + +TEXT VAR testprogramm; + + +PROC trage (TEXT CONST dateiname, FILE VAR protokoll file, BOOL CONST test) : + + disable stop; + testen := test; + IF testen THEN + protokoll := protokoll file; + output (protokoll) + END IF; + trage intern (dateiname); + testen := FALSE + +END PROC trage; + +PROC trage intern (TEXT CONST dateiname) : + + enable stop; + INT VAR modus; + auf ersten satz (modus); + tragen vorbereiten (dateiname); + + INT VAR satzzaehler := 0; + REP + IF NOT ausgewaehlt THEN + weiter (modus) + ELSE + cout (satznummer + satzzaehler) + END IF; + IF dateiende THEN auf satz (1); LEAVE trage intern END IF; + satz testen und tragen + END REP . + +ausgewaehlt : + IF modus = 3 THEN satz markiert ELSE satz ausgewaehlt END IF . + +satz testen und tragen : + test erfolgreich := TRUE; + IF testen THEN + notizen lesen (zieldatei, 1, testprogramm); + do (testprogramm) + END IF; + IF test erfolgreich THEN + trage einzelsatz; + IF test erfolgreich THEN + satz loeschen; + satzzaehler INCR 1 + END IF + END IF; + IF NOT test erfolgreich THEN + weiter (modus) + END IF . + +END PROC trage intern; + +PROC tragen vorbereiten (TEXT CONST dateiname) : + + IF dateiende THEN + errorstop (kein satz vorhanden) + END IF; + oeffne (zieldatei, dateiname); + anzahl eindeutiger felder := 0; + IF felderzahl (zieldatei) = 0 THEN + zieldatei einrichten + ELIF felderzahl (zieldatei) <> anzahl felder THEN + errorstop (falsche felderzahl) + END IF; + auf satz (zieldatei, saetze (zieldatei) + 1) . + +zieldatei einrichten : + satz initialisieren (tragsatz, anzahl felder); + INT VAR feldnr; + FOR feldnr FROM 1 UPTO anzahl felder REP + feldnamen lesen (feldnr, feldpuffer); + feld aendern (tragsatz, feldnr, feldpuffer) + END REP; + feldnamen aendern (zieldatei, tragsatz) . + +END PROC tragen vorbereiten; + +PROC trage einzelsatz : + + IF anzahl eindeutiger felder > 0 CAND schon vorhanden THEN + protokolliere ("", bereits vorhanden) + ELSE + tragsatz aufbauen; + satz einfuegen (zieldatei, tragsatz); + weiter (zieldatei) + END IF . + +tragsatz aufbauen : + satz initialisieren (tragsatz, anzahl felder); + INT VAR feldnr; + FOR feldnr FROM 1 UPTO anzahl felder REP + feld lesen (feldnr, feldpuffer); + feld aendern (tragsatz, feldnr, feldpuffer) + END REP . + +schon vorhanden : + TEXT VAR muster; + INT CONST alte satznummer := satznr (zieldatei); + feld lesen (1, muster); + uebereinstimmung := FALSE; + auf satz (zieldatei, muster); + WHILE NOT dateiende (zieldatei) REP + teste auf uebereinstimmung; + weiter (zieldatei, muster) + UNTIL uebereinstimmung END REP; + auf satz (zieldatei, alte satznummer); + uebereinstimmung . + +teste auf uebereinstimmung : + INT VAR i; + uebereinstimmung := TRUE; + FOR i FROM 2 UPTO anzahl eindeutiger felder REP + feld lesen (zieldatei, i, feldpuffer); + feld bearbeiten (i, + PROC (TEXT CONST, INT CONST, INT CONST) felduebereinstimmung); + IF NOT uebereinstimmung THEN + LEAVE teste auf uebereinstimmung + END IF + END REP . + +END PROC trage einzelsatz; + +PROC felduebereinstimmung (TEXT CONST satz, INT CONST von, bis) : + + IF laengen ungleich COR + (length (feldpuffer) > 0 CAND text ungleich) THEN + uebereinstimmung := FALSE + END IF . + +laengen ungleich : + (bis - von + 1) <> length (feldpuffer) . + +text ungleich : + pos (satz, feldpuffer, von, bis + 1) <> von . + +END PROC felduebereinstimmung; + +PROC protokolliere (TEXT CONST feld, meldung) : + + IF testen THEN + in protokoll + ELSE + errorstop (meldung) + END IF . + +in protokoll : + put (protokoll, t satz); put (protokoll, satznummer); + IF feld <> "" THEN + write (protokoll, t das feld); + write (protokoll, textdarstellung (feld)) + END IF; + putline (protokoll, meldung); + test erfolgreich := FALSE . + +END PROC protokolliere; + +PROC eindeutige felder (INT CONST anzahl) : + + anzahl eindeutiger felder := anzahl + +END PROC eindeutige felder; + +PROC pruefe (TEXT CONST feld, BOOL CONST bedingung) : + + IF NOT bedingung THEN + protokolliere (feld, verletzt die pruefbedingung) + END IF + +END PROC pruefe; + +PROC wertemenge (TEXT CONST feld, menge) : + + INT CONST nr := feldnummer (feld); + IF nr = 0 THEN + protokolliere (feld, nicht definiert) + ELSE + pruefe ob enthalten + END IF . + +pruefe ob enthalten : + INT VAR stelle := 0; + LET komma = ","; + feld lesen (nr, feldpuffer); + IF ist letztes element THEN + LEAVE pruefe ob enthalten + END IF; + feldpuffer CAT komma; + REP + stelle := pos (menge, feldpuffer, stelle + 1); + IF stelle = 1 OR + stelle > 1 CAND (menge SUB stelle - 1) = komma THEN + LEAVE pruefe ob enthalten + END IF + UNTIL stelle = 0 END REP; + protokolliere (feld, nicht in wertemenge) . + +ist letztes element : + INT CONST letzter anfang := length (menge) - length (feldpuffer); + (menge SUB letzter anfang) = komma AND + pos (menge, feldpuffer, letzter anfang + 1) > 0 . + +END PROC wertemenge; + +PROC feldmaske (TEXT CONST feld, maske) : + + INT CONST nr := feldnummer (feld); + IF nr = 0 THEN + protokolliere (feld, nicht definiert) + ELSE + feld lesen (nr, feldpuffer); + mit maske vergleichen + END IF . + +mit maske vergleichen : + INT VAR stelle; + TEXT CONST ende := code (length (maske) + 1); + TEXT VAR moegliche positionen := ""1""; + FOR stelle FROM 1 UPTO length (feldpuffer) REP + TEXT CONST zeichen := feldpuffer SUB stelle; + zeichen vergleichen + UNTIL moegliche positionen = "" END REP; + IF nicht erfolgreich THEN + protokolliere (feld, passt nicht zu maske) + END IF . + +zeichen vergleichen : + INT VAR moeglich := 1; + WHILE moeglich <= length (moegliche positionen) REP + INT CONST position := code (moegliche positionen SUB moeglich); + IF (maske SUB position) = "*" THEN + stern behandeln + ELIF vergleich trifft zu THEN + replace (moegliche positionen, moeglich, code (position + 1)); + moeglich INCR 1 + ELSE + delete char (moegliche positionen, moeglich) + END IF + END REP . + +stern behandeln : + IF position = length (maske) THEN + LEAVE feldmaske + END IF; + moeglich INCR 1; + IF pos (moegliche positionen, code (position + 1)) = 0 THEN + insert char (moegliche positionen, code (position + 1), moeglich) + END IF . + +vergleich trifft zu : + SELECT pos ("9XAa", maske SUB position) OF + CASE 1 : pos ("0123456789", zeichen) > 0 + CASE 2 : TRUE + CASE 3 : pos ("ABCDEFGHIJKLMNOPQRSTUVWXYZÄÖÜ", zeichen) > 0 + CASE 4 : pos ("abcdefghijklmnopqrstuvwxyzäöüß", zeichen) > 0 + OTHERWISE (maske SUB position) = zeichen + END SELECT . + +nicht erfolgreich : + (moegliche positionen = "" COR pos (moegliche positionen, ende) = 0) + AND nicht gerade stern am ende . + +nicht gerade stern am ende : + (maske SUB length (maske)) <> "*" OR + pos (moegliche positionen, code (length (maske))) = 0 . + +END PROC feldmaske; + +PROC trage satz (TEXT CONST dateiname) : + + tragen vorbereiten (dateiname); + INT CONST alter satz := satznr (zieldatei); + trage einzelsatz; + satz loeschen; + auf satz (zieldatei, alter satz) + +END PROC trage satz; + +PROC hole satz (TEXT CONST dateiname) : + + teste ob datei vorhanden; + IF NOT exists (dateiname) THEN + errorstop (textdarstellung (dateiname) + existiert nicht) + END IF; + oeffne (zieldatei, dateiname); + IF felderzahl (zieldatei) <> anzahl felder THEN + errorstop (falsche felderzahl) + ELIF saetze (zieldatei) = 0 THEN + errorstop (kein satz vorhanden) + END IF; + auf satz (zieldatei, saetze (zieldatei)); + satz lesen (zieldatei, tragsatz); + tragsatz einfuegen; + satz loeschen (zieldatei) . + +tragsatz einfuegen : + satz einfuegen; + INT VAR feldnr; + FOR feldnr FROM 1 UPTO felderzahl (tragsatz) REP + feld lesen (tragsatz, feldnr, feldpuffer); + feld aendern (feldnr, feldpuffer) + END REP . + +END PROC hole satz; + +END PACKET verarbeitung; + |