summaryrefslogtreecommitdiff
path: root/app/conversion/1.0/src/ASKCNVRS.PAC
diff options
context:
space:
mode:
Diffstat (limited to 'app/conversion/1.0/src/ASKCNVRS.PAC')
-rw-r--r--app/conversion/1.0/src/ASKCNVRS.PAC349
1 files changed, 349 insertions, 0 deletions
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"")#", "<I>");
+ change all (t, "#off(""i"")#", "<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;