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/conversion/1.0/src/ASKCNVRS.PAC | 349 ++++++++++++++++++++++++++++++++++++ 1 file changed, 349 insertions(+) create mode 100644 app/conversion/1.0/src/ASKCNVRS.PAC (limited to 'app/conversion/1.0/src/ASKCNVRS.PAC') diff --git a/app/conversion/1.0/src/ASKCNVRS.PAC b/app/conversion/1.0/src/ASKCNVRS.PAC new file mode 100644 index 0000000..7d9dddd --- /dev/null +++ b/app/conversion/1.0/src/ASKCNVRS.PAC @@ -0,0 +1,349 @@ +PACKET asksam conversion DEFINES append asksam field, + append asksam record, + convert to asksam : +LET card prefix = " +--", + bo field = "[ ", + eo field = " ]", + eo line = ""13""10"", + eo record = ""0"", + eo doc = ""0""0"", + dummy fn = "@"; +LET max fields = 50; +TEXT VAR in l, out l, appended l, asksam record, buffer; +INT VAR card no, in line no, out line no, last named field, + start pos, end pos, card lines, first line; +FILE VAR f in, f out; +THESAURUS VAR field names; +ROW max fields BOOL VAR complex fields, + to be copied; +PROC convert to asksam (TEXT CONST input file) : + IF NOT exists (input file) THEN errorstop ("") FI; + TEXT CONST output file := dos file name (input file, "sam"); + forget (output file); + f out := sequential file (output, output file); + field names := empty thesaurus; + IF input is eudas + THEN convert eudas to asksam (input file) + ELIF input is cardbox + THEN convert cardbox to asksam + ELSE stop process + FI +. +input is eudas : + type (old (input file)) = 3243 +. +input is cardbox : + IF type (old (input file)) = 1003 + THEN f in := sequential file (modify, input file); + toline (f in, 1); + down (f in, ""26""26""); + pattern found + ELSE FALSE + FI +. +stop process : + forget (output file, quiet); + errorstop ("Konversion nur f"219"r EUDAS- und Cardbox-Dateien m"218"glich.") +END PROC convert to asksam; +PROC convert eudas to asksam (TEXT CONST file name) : + oeffne (file name, FALSE); + get field names; + WHILE NOT dateiende REP + transfer one record; + weiter (1) + PER; + dateien loeschen (FALSE) +. +get field names : + asksam record := ""; + last named field := anzahl felder; + auf satz (1); + FOR in line no FROM 1 UPTO last named field REP + feld lesen (in line no, in l); + IF in l <> "" + THEN to be copied [in line no] := TRUE; + complex fields [in line no] := is complex field; + append field name (in l); + feldnamen lesen (in line no, in l); + append asksam field (in l) + ELSE to be copied [in line no] := FALSE; + append field name (dummy fn) + FI + PER; + append asksam record; + weiter (1) +. +is complex field : + end pos := pos (in l, "{"); + IF end pos <> 0 + THEN end pos DECR 1; + WHILE (in l SUB end pos) = " " REP + end pos DECR 1 + PER; + in l := subtext (in l, 1, end pos); + TRUE + ELSE FALSE + FI +. +transfer one record : + cout (satznummer); + asksam record := ""; + out line no := 0; + transfer fields; + append asksam record +. +transfer fields : + FOR in line no FROM 1 UPTO last named field REP + IF to be copied [in line no] + THEN feld lesen (in line no, in l); + IF in l <> "" + THEN IF complex fields [in line no] + THEN transfer complex field (in l) + ELSE append asksam field (in l) + FI + FI + FI + PER +END PROC convert eudas to asksam; +PROC transfer complex field (TEXT CONST l) : + TEXT VAR transfer buffer; + start pos := 1; + REP + start pos INCR 1; + end pos := pos (l, "{", start pos + 1); + IF end pos = 0 + THEN end pos := LENGTH l + ELSE end pos DECR 1 + FI; + WHILE (l SUB end pos) = " " REP + end pos DECR 1 + PER; + transfer buffer := subtext (l, start pos, end pos); + change (transfer buffer, "}", ""); + append asksam field (transfer buffer); + start pos := pos (l, "{", end pos) + UNTIL start pos = 0 PER +END PROC transfer complex field; +PROC convert cardbox to asksam : + BOOL VAR line end; + ascertain number lines per card; + convert file; +. +ascertain number lines per card : + toline (f in, 1); + col (f in, 1); + downety (f in, card prefix); + first line := line no (f in); + down (f in, card prefix); + card lines := line no (f in) - first line +. +convert file : + line; + input (f in); + get field names; + card no := 0; + WHILE NOT eof (f in) REP + transfer one card + UNTIL asksam record = "" PER +. +get field names : + last named field := 0; + getline (f in, in l); + get names from first lines; + get names from bulk; +. +get names from first lines : + FOR in line no FROM 1 UPTO card lines - 2 REP + get cardbox line (in l); + in l := compress (in l); + IF in l > "" + THEN append field name (in l); + last named field := in line no + ELSE append field name (dummy fn) + FI + PER; +. +get names from bulk : + in line no := card lines - 2; + get cardbox line (in l); + end pos := 0; + REP + get card line (appended l, line end); + IF line end + THEN LEAVE get names from bulk + ELIF appended l <> "" + THEN in line no INCR 1; + append field name (compress (appended l)); + last named field INCR 1 + FI; + PER +END PROC convert cardbox to asksam; +PROC transfer one card : + BOOL VAR line end; + card no INCR 1; + cout (card no); + asksam record := ""; + transfer first lines; + transfer bulk line; + append asksam record +. +transfer first lines : + getline (f in, in l); + IF pos (in l, card prefix) <> 2 + THEN errorstop ("Programmfehler 1") + ELIF pos (in l, "LAST CARD") <> 0 + THEN LEAVE transfer one card + FI; + out line no := 0; + FOR in line no FROM 1 UPTO card lines - 2 REP + get cardbox line (in l); + IF pos (in l, ""25""25"") = 1 + THEN process hypertext + ELSE append asksam field (in l) + FI; + PER +. +process hypertext : + asksam record CAT ":"13""10""9""; + end pos := pos (in l, ".card") - 1; + appended l := subtext (in l, 55, end pos); + asksam record CAT appended l; + asksam record CAT ""255""13""10""13""10""; + asksam record CAT "(Datei zum Thema `"; + asksam record CAT appended l; + asksam record CAT "')"13""10""; + out line no := 4 +. +transfer bulk line : + get cardbox line (in l); + end pos := 0; + first line := 0; + in line no DECR 1; + REP + get card line (appended l, line end); + IF line end + THEN LEAVE transfer bulk line + FI; + in line no INCR 1; + cout (in line no); + append asksam field (appended l) + PER +END PROC transfer one card; +PROC get cardbox line (TEXT VAR t) : + getline (f in, t); + start pos := pos (t, "|"); + IF start pos = 0 + THEN errorstop ("Programmfehler 2") + FI; + t := subtext (t, start pos + 1) +END PROC get cardbox line; +PROC get card line (TEXT VAR t, BOOL VAR end) : + start pos := pos (in l, ""32"", ""255"", endpos + 1); + IF start pos = 0 + THEN end := TRUE; + LEAVE get card line + FI; + end pos := pos (in l, ""26"", start pos); + IF end pos = 0 + THEN end := TRUE; + LEAVE get card line + FI; + end pos DECR 1; + t := subtext (in l, start pos, end pos); + end := FALSE +END PROC get card line; +PROC append asksam line (TEXT CONST t) : + asksam record CAT t; + out line no INCR 1; + IF out line no MOD 20 = 0 + THEN asksam record CAT eo record + ELSE asksam record CAT eo line + FI +END PROC append asksam line; +PROC append asksam field (TEXT CONST t) : + BOOL VAR named field; + INT VAR s pos, e pos, length l; + IF t > " " CAND in line no <= last named field + THEN get field name (in line no, out l); + IF out l <> dummy fn + THEN out l CAT bo field; + named field := TRUE + ELSE out l := ""; + named field := FALSE + FI + ELSE out l := ""; + named field := FALSE + FI; + buffer := t; + prepare line for asksam (buffer); + out l CAT buffer; + transfer line +. +transfer line : + length l := LENGTH out l; + e pos := -1; + REP + s pos := e pos + 2; + IF (length l - s pos) > 79 + THEN determine e pos; + transfer chunk + ELSE transfer rest + FI + PER +. +determine e pos : + e pos := s pos + 79; + move before last blank +. +move before last blank : + WHILE (out l SUB e pos) <> " " REP + e pos DECR 1 + UNTIL e pos = s pos PER; + IF e pos = s pos + THEN e pos := s pos + 79 + ELSE e pos DECR 1 + FI +. +transfer chunk : + append asksam line (subtext (out l, s pos, e pos)); +. +transfer rest : + buffer := subtext (out l, s pos); + IF named field + THEN buffer CAT eo field + FI; + append asksam line (buffer); + LEAVE transfer line +END PROC append asksam field; +PROC append asksam record : + IF was eo record + THEN asksam record CAT eo record + ELSE buffer := subtext (asksam record, 1, LENGTH asksam record - 2); + buffer CAT eo doc; + asksam record := buffer + FI; + putline (f out, asksam record) +. +was eo record : + out line no MOD 20 = 0 +END PROC append asksam record; +PROC prepare line for asksam (TEXT VAR t) : + IF (t SUB LENGTH t) = " " + THEN t := subtext (t, 1, LENGTH t - 1) + FI; + replace eumel special characters (t); + change all (t, "[", ""174""); + change all (t, "]", ""175""); + change all (t, "#on(""i"")#", ""); + change all (t, "#off(""i"")#", "") +END PROC prepare line for asksam; +PROC append field name (TEXT CONST fn) : + INT VAR index; + buffer := fn; + prepare line for asksam (buffer); + insert (field names, buffer, index) +END PROC append field name; +PROC get field name (INT CONST index, TEXT VAR fn) : + fn := name (field names, index) +END PROC get field name; +END PACKET asksam conversion; -- cgit v1.2.3