MODULE TextUtilities; (** AUTHOR "TF"; PURPOSE "Utilities for the Unicode text system"; *) IMPORT SYSTEM, (* for Oberon Text colors *) Configuration, Commands, Codecs, FP1616, KernelLog, Texts, Streams, Files, UTF8Strings, XML, XMLScanner, XMLParser, XMLObjects, Repositories, Strings, WMGraphics, UnicodeProperties; CONST Ok* = 0; FileNotFound* = Files.FileNotFound; FileCreationError* = 2; CodecNotFound* = 3; CR = 0DX; LF = 0AX; TAB = 09X; (** FormatDescriptor features *) LoadUnicode* = 0; StoreUnicode* = 1; LoadFormated* = 2; StoreFormatted* = 3; BufferedAttributes=256; (* number of attributes buffered before updates must take place *) TYPE Char32 = Texts.Char32; Text = Texts.Text; LoaderProc* = PROCEDURE {DELEGATE} (text : Text; filename : ARRAY OF CHAR; VAR res : WORD); TYPE FormatDescriptor = OBJECT VAR name : Strings.String; loadProc, storeProc : Strings.String; END FormatDescriptor; AttributesBuf*=RECORD attributes: POINTER TO ARRAY OF Texts.Attributes; positions: POINTER TO ARRAY OF LONGINT; length: LONGINT; END; TextWriter* = OBJECT (Streams.Writer); VAR text : Texts.Text; ucs32buf : POINTER TO ARRAY OF LONGINT; fontName : ARRAY 32 OF CHAR; fontSize, x, fontVOff : LONGINT; fontColor, fontBgColor: WMGraphics.Color; fontStyle : SET; currentAttributes- : Texts.Attributes; oldBytes : ARRAY 7 OF CHAR; nofOldBytes : LONGINT; attributesBuf: AttributesBuf; PROCEDURE &Init*(text : Texts.Text); BEGIN SELF.text := text; nofOldBytes := 0; currentAttributes := GetDefaultAttributes(); fontColor := currentAttributes.color; fontBgColor := currentAttributes.bgcolor; fontVOff := currentAttributes.voff; COPY(currentAttributes.fontInfo.name, fontName); fontSize := currentAttributes.fontInfo.size; fontStyle := currentAttributes.fontInfo.style; NEW(attributesBuf.attributes,BufferedAttributes); NEW(attributesBuf.positions,BufferedAttributes); attributesBuf.length := 0; InitWriter (Add, 128 * 1024); END Init; PROCEDURE Add(CONST buf: ARRAY OF CHAR; ofs, len: LONGINT; propagate: BOOLEAN; VAR res: WORD); VAR p, i, idx, pos : LONGINT; nextAttribute: LONGINT; pieceOffset, pieceLength: LONGINT; nextAttributes: Texts.Attributes; BEGIN pieceOffset := ofs; pieceLength := len; IF (ucs32buf = NIL) OR (pieceLength >= LEN(ucs32buf)) THEN NEW(ucs32buf, pieceLength + 1) END; p := pieceOffset; idx := 0; (* complete an unfinished character *) IF nofOldBytes > 0 THEN FOR i := nofOldBytes TO ORD(UTF8Strings.CodeLength[ORD(oldBytes[0])]) - 1 DO oldBytes[i] := buf[p]; INC(p) END; i := 0; IF UTF8Strings.DecodeChar(oldBytes, i, ucs32buf[idx]) THEN INC(idx) END; nofOldBytes := 0 END; WHILE (p < pieceOffset + pieceLength) & (ORD(UTF8Strings.CodeLength[ORD(buf[p])]) <= pieceOffset+pieceLength) & UTF8Strings.DecodeChar(buf, p, ucs32buf[idx]) DO INC(idx) END; ucs32buf[idx] := 0; IF (p < pieceOffset + pieceLength) & (ORD(UTF8Strings.CodeLength[ORD(buf[p])]) >= pieceOffset+pieceLength) THEN (* could not be decoded because of missing bytes. ignore other problems *) WHILE p < pieceOffset+pieceLength DO oldBytes[i] := buf[p]; INC(p); INC(i) END; nofOldBytes := i; KernelLog.String("Update within UTF sequence "); KernelLog.Ln; END; IF len > 0 THEN text.AcquireWrite; pos := text.GetLength(); text.InsertUCS32(text.GetLength(), ucs32buf^); pieceOffset := 0; nextAttribute := 0; WHILE nextAttribute < attributesBuf.length DO nextAttributes := attributesBuf.attributes[nextAttribute]; pieceLength:= attributesBuf.positions[nextAttribute]-pieceOffset; text.SetAttributes(pos+pieceOffset,pieceLength,currentAttributes); INC(pieceOffset, pieceLength); currentAttributes := nextAttributes; INC(nextAttribute); END; text.SetAttributes(pieceOffset+pos, text.GetLength()-pos-pieceOffset, currentAttributes); text.ReleaseWrite; attributesBuf.length := 0; END; END Add; (** Write end-of-line character *) PROCEDURE Ln*; (** overwrite Ln^ *) BEGIN Char(CHR(Texts.NewLineChar)); END Ln; PROCEDURE SetAttributes*(attributes: Texts.Attributes); VAR i: LONGINT; BEGIN IF attributesBuf.length = LEN(attributesBuf.attributes) THEN Update(); END; i := attributesBuf.length; attributesBuf.attributes[i] := attributes; attributesBuf.positions[i] := Pos()-sent; INC(i); attributesBuf.length := i; END SetAttributes; PROCEDURE NewAttributes(): Texts.Attributes; VAR attributes: Texts.Attributes; BEGIN NEW(attributes); attributes.Set(fontColor, fontBgColor, fontVOff, fontName, fontSize, fontStyle); RETURN attributes END NewAttributes; PROCEDURE SetFontName* (CONST name : ARRAY OF CHAR); BEGIN COPY(name, fontName); SetAttributes(NewAttributes()); END SetFontName; PROCEDURE SetFontSize* (size : LONGINT); BEGIN fontSize := size; SetAttributes(NewAttributes()); END SetFontSize; PROCEDURE SetFontStyle* (style : SET); BEGIN fontStyle := style; SetAttributes(NewAttributes()); END SetFontStyle; PROCEDURE SetFontColor* (color : WMGraphics.Color); BEGIN fontColor := color; SetAttributes(NewAttributes()); END SetFontColor; PROCEDURE SetBgColor* (bgColor : LONGINT); BEGIN fontBgColor := bgColor; SetAttributes(NewAttributes()); END SetBgColor; PROCEDURE SetVerticalOffset* (voff : LONGINT); BEGIN fontVOff := voff; SetAttributes(NewAttributes()); END SetVerticalOffset; PROCEDURE AddObject*(obj : ANY); VAR op : Texts.ObjectPiece; BEGIN Update; NEW(op); op.object := obj; text.AcquireWrite; text.InsertPiece(text.GetLength(), op); text.ReleaseWrite; END AddObject; END TextWriter; TextReader* = OBJECT (Streams.Reader) VAR reader: Texts.TextReader; remainder: LONGINT; PROCEDURE &Init*(text : Texts.Text); BEGIN remainder := 0; NEW (reader, text); InitReader (Receive, Streams.DefaultReaderSize); END Init; PROCEDURE Receive (VAR buf: ARRAY OF CHAR; ofs, size, min: LONGINT; VAR len: LONGINT; VAR res: WORD); VAR ucs32, prevofs: LONGINT; BEGIN reader.text.AcquireRead; len := 0; res := Streams.Ok; WHILE len < size DO IF remainder # 0 THEN ucs32 := remainder; remainder := 0; ELSE reader.ReadCh (ucs32); END; prevofs := ofs; IF (ucs32 = 0) OR ~UTF8Strings.EncodeChar (ucs32, buf, ofs) THEN remainder := ucs32; IF len < min THEN res := Streams.EOF END; reader.text.ReleaseRead; RETURN END; INC (len, ofs - prevofs); END; reader.text.ReleaseRead; END Receive; PROCEDURE CanSetPos*() : BOOLEAN; BEGIN RETURN TRUE; END CanSetPos; PROCEDURE SetPos*(pos: Streams.Position); BEGIN reader.text.AcquireRead; reader.SetPosition(pos); (* pos is clipped *) received := reader.GetPosition(); (* this effects that Streams.Reader.Pos() returns the correct location in the text *) Reset; remainder := 0; reader.text.ReleaseRead; END SetPos; END TextReader; TYPE LongintArray = POINTER TO ARRAY OF LONGINT; Operation = RECORD op, pos, len : LONGINT END; Operations = POINTER TO ARRAY OF Operation; TextSelection*=OBJECT VAR text* : Texts.Text; from*, to* : Texts.TextPosition; END TextSelection; TextPositionKeeper* = OBJECT(Texts.TextPosition); VAR positions : LongintArray; nofPositions : LONGINT; operations : Operations; nofOperations, nofDeleted : LONGINT; PROCEDURE &New*(t : Texts.Text); BEGIN New^(t); NEW(positions, 256); NEW(operations, 256); nofOperations := 0; nofPositions := 0; nofDeleted := 0 END New; PROCEDURE GrowOperations; VAR i : LONGINT; t : Operations; BEGIN NEW(t, nofOperations * 2); FOR i := 0 TO nofOperations - 1 DO t[i] := operations[i] END; operations := t END GrowOperations; PROCEDURE Cleanup; VAR i, j, p, op, pos : LONGINT; BEGIN IF nofOperations = 0 THEN RETURN END; FOR i := 0 TO nofPositions - 1 DO p := positions[i]; IF p >= 0 THEN FOR j := 0 TO nofOperations - 1 DO op := operations[j].op; pos := operations[j].pos; IF (p >= pos) & (op = Texts.OpInsert) THEN INC(p, operations[j].len) ELSIF (p >= pos) & (p <= pos + operations[j].len) & (op = Texts.OpDelete) THEN p := pos ELSIF (p > pos) & (op = Texts.OpDelete) THEN DEC(p, operations[j].len); END END; IF p < 0 THEN p := 0 END; positions[i] := p END END; nofOperations := 0 END Cleanup; (** Listens for text changes *) PROCEDURE Changed*(op, pos, len : LONGINT); CONST MaxOperations = 4096; BEGIN IF nofOperations > MaxOperations THEN Cleanup END; IF nofOperations >= LEN(operations) THEN GrowOperations END; operations[nofOperations].op := op; operations[nofOperations].pos := pos; operations[nofOperations].len := len; INC(nofOperations) END Changed; PROCEDURE GrowPositions; VAR i : LONGINT; t : LongintArray; BEGIN NEW(t, nofPositions * 2); FOR i := 0 TO nofPositions - 1 DO t[i] := positions[i] END; positions := t END GrowPositions; PROCEDURE DeletePos*(index : LONGINT); BEGIN positions[index] := -1; INC(nofDeleted) END DeletePos; PROCEDURE AddPos*(pos : LONGINT) : LONGINT; VAR i : LONGINT; BEGIN ASSERT(pos >= 0); Cleanup; IF nofDeleted > 0 THEN i := 0; WHILE (i < nofPositions) & (positions[i] >= 0) DO INC(i) END; ASSERT(i < nofPositions); positions[i] := pos; DEC(nofDeleted); RETURN i ELSE IF nofPositions >= LEN(positions) THEN GrowPositions END; positions[nofPositions] := pos; INC(nofPositions); RETURN nofPositions - 1 END END AddPos; (** throw away all positions *) PROCEDURE Clear*; BEGIN nofPositions := 0; nofOperations := 0 END Clear; (** Returns position in elements from the text start *) PROCEDURE GetPos*(index : LONGINT):LONGINT; BEGIN Cleanup; RETURN positions[index] END GetPos; (** Change the position associated with index*) PROCEDURE SetPos*(index, pos : LONGINT); BEGIN Cleanup; positions[index] := pos END SetPos; END TextPositionKeeper; OberonDecoder = OBJECT(Codecs.TextDecoder) VAR errors : BOOLEAN; in : Streams.Reader; text : Texts.Text; buffer : Strings.Buffer; string: Strings.String; reader, sreader : Streams.StringReader; PROCEDURE Error(CONST x : ARRAY OF CHAR); BEGIN KernelLog.String("Oberon Decoder Error: "); KernelLog.String(x); KernelLog.Ln; errors := TRUE END Error; PROCEDURE LoadLibrary(buf: Strings.Buffer; pos:LONGINT; VARflen:LONGINT); END LoadLibrary; PROCEDURE IndexToColor(index: LONGINT): LONGINT; BEGIN RETURN ASH(SYSTEM.VAL(LONGINT, SYSTEM.VAL(SET, index) * {5..7}), 23-7) + ASH(SYSTEM.VAL(LONGINT, SYSTEM.VAL(SET, index) * {2..4}), 15-4) + ASH(SYSTEM.VAL(LONGINT, SYSTEM.VAL(SET, index) * {0..1}), 7-1) END IndexToColor; PROCEDURE InsertPiece(ofs, len : LONGINT; attr : Texts.Attributes); VAR i, j, m : LONGINT; ch, last : CHAR; tempUCS32 : ARRAY 1024 OF Char32; oldpos : LONGINT; BEGIN m := LEN(tempUCS32) - 1; sreader.SetPos(ofs); oldpos := text.GetLength(); FOR j := 0 TO len - 1 DO ch := sreader.Get(); IF i = m THEN tempUCS32[i] := 0; text.InsertUCS32(text.GetLength(), tempUCS32); i := 0 END; IF (last # CR) OR (ch # LF) THEN IF ch = CR THEN tempUCS32[i] := ORD(LF) ELSE tempUCS32[i] := OberonToUni(ORD(ch)) END; INC(i) END; last := ch END; tempUCS32[i] := 0; text.InsertUCS32(text.GetLength(), tempUCS32); IF attr # NIL THEN text.SetAttributes(oldpos, len, attr) END END InsertPiece; PROCEDURE Open*(in : Streams.Reader; VAR res : WORD); CONST DocBlockId = 0F7X; OldTextBlockId = 1X; TextBlockId = 0F0X; OldTextSpex = 0F0X; TextSpex = 1X; LibBlockId = 0DBX; VAR ch: CHAR; tempInt : LONGINT; buflen: LONGINT; attr : Texts.Attributes; tattr : Texts.FontInfo; fonts : ARRAY 256 OF Texts.FontInfo; col: SHORTINT; voff: SHORTINT; lib :SHORTINT; type, tag: CHAR; len, flen, n, off, hlen, tlen, pos, templen: LONGINT; x, y, w, h: INTEGER; temp: ARRAY 4096 OF CHAR; name, lName: ARRAY 32 OF CHAR; oberonColors : ARRAY 16 OF LONGINT; BEGIN errors := FALSE; res := -1; IF in = NIL THEN Error("Input Stream is NIL"); RETURN; END; SELF.in := in; (* write stream into buffer for further processing *) NEW(buffer, 64 * 1024); REPEAT in.Bytes(temp, 0, 4096, buflen); buffer.Add(temp, 0, buflen, FALSE, res); UNTIL (in.res # Streams.Ok); (* define Oberon Colors *) oberonColors[0] := LONGINT(0FFFFFFFFH); oberonColors[1] := LONGINT(0FF0000FFH); oberonColors[2] := 000FF00FFH; oberonColors[3] := 00000FFFFH; oberonColors[4] := LONGINT(0FF00FFFFH); oberonColors[5] := LONGINT(0FFFF00FFH); oberonColors[6] := 000FFFFFFH; oberonColors[7] := LONGINT(0AA0000FFH); oberonColors[8] := 000AA00FFH; oberonColors[9] := 00000AAFFH; oberonColors[10] := LONGINT(0A6BCF3FFH); oberonColors[11] := 0008282FFH; oberonColors[12] := LONGINT(08A8A8AFFH); oberonColors[13] := LONGINT(0BEBEBEFFH); oberonColors[14] := 07B7B7BFFH; oberonColors[15] := 0000000FFH; NEW(text); text.AcquireWrite; string := buffer.GetString(); NEW(reader, buffer.GetLength()); reader.SetRaw(string^, 0, buffer.GetLength()); ch := reader.Get(); IF ch = DocBlockId THEN (* skip doc header *) reader.RawString(name); reader.RawInt(x); reader.RawInt(y); reader.RawInt(w); reader.RawInt(h); ch := reader.Get(); IF ch = 0F7X THEN (* skip meta info *) ch := reader.Get(); IF ch = 08X THEN reader.RawLInt(len); reader.Bytes(temp, 0, len, templen); ch := reader.Get(); END; END END; pos := reader.Pos(); IF (ch = TextBlockId) OR (ch = OldTextBlockId) THEN type := reader.Get(); reader.RawLInt(hlen); NEW(sreader, buffer.GetLength()); tempInt := pos - 1 + hlen - 4; sreader.SetRaw(string^, 0, buffer.GetLength()); sreader.SetPos(tempInt); sreader.RawLInt(tlen); IF (type = TextSpex) OR (type = OldTextSpex) THEN (*T.obs := NIL; flen := 0 *) ELSE (* NEW(T.obs); Objects.OpenLibrary(T.obs); *) tempInt := pos - 1 + hlen + tlen; sreader.SetPos(tempInt); tag := sreader.Get(); IF tag = LibBlockId THEN LoadLibrary(buffer, pos - 1 + hlen + tlen + 1, flen) END; INC(flen) END; n := 1; off := pos - 1 + hlen; WHILE reader.Pos() < pos - 1 + hlen - 5 DO reader.RawSInt(lib); IF lib = n THEN reader.RawString(lName); NEW(fonts[n]); COPY(lName, fonts[n].name); DecodeOberonFontName(lName, fonts[n].name, fonts[n].size, fonts[n].style); tattr := fonts[n]; INC(n) ELSE IF (lib >= 0) & (lib < 255) & (fonts[lib] # NIL) THEN tattr := fonts[lib]; END END; reader.RawSInt(col); reader.RawSInt(voff); voff := - voff; reader.RawLInt(len); IF len < 0 THEN KernelLog.Enter; KernelLog.String(" LoadAscii (T, f);"); KernelLog.Int(len, 0); KernelLog.Exit; RETURN END; NEW(attr); CASE col OF 0..15 : attr.color := oberonColors[col] ELSE attr.color := IndexToColor(col) * 100H + 0FFH END; attr.voff := voff; NEW(attr.fontInfo); IF tattr # NIL THEN COPY(tattr.name, attr.fontInfo.name); attr.fontInfo.style := tattr.style; attr.fontInfo.size := tattr.size END; IF lib > 0 THEN (* ignore objects for now *) InsertPiece(off, len, attr) END; off := off + len END; res := 0; ELSE Error("Not an Oberon File Format!"); END; text.ReleaseWrite; END Open; PROCEDURE GetText*() : Texts.Text; BEGIN RETURN text; END GetText; (* map oberon to unicode *) PROCEDURE OberonToUni(ch : LONGINT) : LONGINT; VAR ret : LONGINT; BEGIN CASE ch OF 128 : ret := 0C4H; | 129 : ret:= 0D6H; | 130 : ret:= 0DCH; | 131 : ret:= 0E4H; | 132 : ret:= 0F6H; | 133 : ret:= 0FCH; | 134 : ret:= 0E2H; | 135 : ret:= 0EAH; | 136 : ret:= 0EEH; | 137 : ret:= 0F4H; | 138 : ret:= 0FBH; | 139 : ret:= 0E0H; | 140 : ret:= 0E8H; | 141 : ret:= 0ECH; | 142 : ret:= 0F2H; | 143 : ret:= 0F9H; | 144 : ret:= 0E9H; | 145 : ret:= 0EBH; | 146 : ret:= 0EFH; | 147 : ret:= 0E7H; | 148 : ret:= 0E1H; | 149 : ret:= 0F1H; | 150 : ret:= 0DFH; | 151 : ret:= 0A3H; | 152 : ret:= 0B6H; | 153 : ret:= 0C7H; | 154 : ret:= 2030H; | 155 : ret:= 2013H; ELSE ret := ch END; RETURN ret END OberonToUni; END OberonDecoder; OberonEncoder = OBJECT(Codecs.TextEncoder) VAR out, w: Streams.Writer; w2: Streams.StringWriter; string: Strings.String; buffer : Strings.Buffer; oberonColors : ARRAY 16 OF LONGINT; fonts : ARRAY 256 OF Texts.FontInfo; font : Texts.FontInfo; nofFonts, hLen : LONGINT; firstPiece : BOOLEAN; voff: LONGINT; color : LONGINT; PROCEDURE Open*(out : Streams.Writer); BEGIN IF out = NIL THEN KernelLog.String("Oberon Encoder Error: output stream is NIL"); ELSE SELF.out := out; END; END Open; PROCEDURE ColorToIndex(col: LONGINT): LONGINT; BEGIN RETURN SYSTEM.VAL(LONGINT, SYSTEM.VAL(SET, ASH(col, 7-23)) * {5..7} + SYSTEM.VAL(SET, ASH(col, 4-15)) * {2..4} + SYSTEM.VAL(SET, ASH(col, 1-7)) * {0..1}) END ColorToIndex; PROCEDURE GetOberonColor(color : LONGINT):LONGINT; VAR i: LONGINT; BEGIN i := 0; WHILE i < LEN(oberonColors) DO IF oberonColors[i] = color THEN RETURN i END; INC(i) END; RETURN ColorToIndex(color DIV 100H) END GetOberonColor; PROCEDURE WritePiece(len: LONGINT); VAR i :LONGINT; oname : ARRAY 32 OF CHAR; BEGIN IF (font # NIL) THEN i := 0; WHILE (i < nofFonts) & (~fonts[i].IsEqual(font)) DO INC(i) END; IF (i = nofFonts) THEN IF ToOberonFont(font.name, font.size, font.style, oname) THEN w.RawSInt(SHORT(SHORT(i+1))); IF i = nofFonts THEN w.RawString(oname); fonts[nofFonts] := font; INC(nofFonts) END ELSE w.RawSInt(1); IF firstPiece THEN w.RawString("Oberon10.Scn.Fnt"); NEW(fonts[nofFonts]); fonts[nofFonts].name := "Oberon"; fonts[nofFonts].size := 10; fonts[nofFonts].style := {}; INC(nofFonts) END; END ELSE w.RawSInt(SHORT(SHORT(i+1))); END ELSE w.RawSInt(1); IF firstPiece THEN w.RawString("Oberon10.Scn.Fnt"); NEW(fonts[nofFonts]); fonts[nofFonts].name := "Oberon"; fonts[nofFonts].size := 10; fonts[nofFonts].style := {}; INC(nofFonts) END; END; firstPiece := FALSE; w.RawSInt(SHORT(SHORT(GetOberonColor(color)))); w.RawSInt(SHORT(SHORT(-voff))); w.RawLInt(len); END WritePiece; PROCEDURE WriteText*(text : Texts.Text; VAR res : WORD); CONST TextBlockId = 0F0X; VAR r: Texts.TextReader; ch :Char32; startPos, i, len, tempInt : LONGINT; BEGIN (* define Oberon colors *) oberonColors[0] := LONGINT(0FFFFFFFFH); oberonColors[1] := LONGINT(0FF0000FFH); oberonColors[2] := 000FF00FFH; oberonColors[3] := 00000FFFFH; oberonColors[4] := LONGINT(0FF00FFFFH); oberonColors[5] := LONGINT(0FFFF00FFH); oberonColors[6] := 000FFFFFFH; oberonColors[7] := LONGINT(0AA0000FFH); oberonColors[8] := 000AA00FFH; oberonColors[9] := 00000AAFFH; oberonColors[10] := LONGINT(0A6BCF3FFH); oberonColors[11] := 0008282FFH; oberonColors[12] := LONGINT(08A8A8AFFH); oberonColors[13] := LONGINT(0BEBEBEFFH); oberonColors[14] := 07B7B7BFFH; oberonColors[15] := 0000000FFH; res := -1; text.AcquireRead; firstPiece := TRUE; NEW(r, text); NEW(buffer, 1024); w := buffer.GetWriter(); nofFonts := 0; w.Char(TextBlockId); w.Char(01X); (* simple text *) w.RawLInt(0); (* header len place holder *) startPos := 1; len := 0; REPEAT r.ReadCh(ch); IF ~r.eot & (ch >= 0) & (ch < 256) THEN INC(len); IF len < 2 THEN font := r.font; voff := r.voff; color := r.color END; IF (r.font # font) OR (r.voff # voff) OR (r.color # color) THEN WritePiece(len - startPos); font := r.font; voff := r.voff; color := r.color; startPos := len; END END UNTIL r.eot; WritePiece(len + 1 - startPos); w.Char(0X); (* ??? *) w.RawLInt(len); (* tLen ? *) w.Update; hLen := w.Pos(); (* pure text ... *) r.SetPosition(0); FOR i := 0 TO text.GetLength() - 1 DO r.ReadCh(ch); IF ch = Texts.NewLineChar THEN ch := 0DH END; IF (ch >=0) & (ch < 256) THEN w.Char(CHR(UniToOberon(ch))) END END; (* fixup header length *) w.Update; string := buffer.GetString(); NEW(w2, LEN(string)); w2.Bytes(string^, 0, LEN(string)); tempInt := w2.Pos(); w2.SetPos(2); w2.RawLInt(hLen); w2.SetPos(tempInt); w2.Update; (* write string to output stream *) NEW(string, text.GetLength()+hLen); w2.GetRaw(string^, len); out.Bytes(string^, 0, len); out.Update; text.ReleaseRead; res := 0 END WriteText; (* map unicode to oberon *) PROCEDURE UniToOberon(ch : LONGINT) : LONGINT; VAR ret : LONGINT; BEGIN CASE ch OF 0C4H : ret := 128; | 0D6H : ret := 129; | 0DCH : ret := 130; | 0E4H : ret := 131; | 0F6H : ret := 132; | 0FCH : ret := 133; | 0E2H : ret := 134; | 0EAH : ret := 135; | 0EEH : ret := 136; | 0F4H : ret := 137; | 0FBH : ret := 138; | 0E0H : ret := 139; | 0E8H : ret := 140; | 0ECH : ret := 141; | 0F2H : ret := 142; | 0F9H : ret := 143; | 0E9H : ret := 144; | 0EBH : ret := 145; | 0EFH : ret := 146; | 0E7H : ret := 147; | 0E1H : ret := 148; | 0F1H : ret := 149; | 0DFH : ret := 150; | 0A3H : ret := 151; | 0B6H : ret := 152; | 0C7H : ret := 153; ELSE IF ch = 2030H THEN ret := 154 ELSIF ch = 2013H THEN ret := 155 ELSE ret := ch END END; RETURN ret END UniToOberon; END OberonEncoder; BluebottleDecoder* = OBJECT(Codecs.TextDecoder) VAR errors : BOOLEAN; text : Texts.Text; doc : XML.Document; cont, tc, tc2 : XMLObjects.Enumerator; ptr : ANY; root : XML.Element; str : Strings.String; o : Texts.ObjectPiece; attr: Texts.Attributes; fi : Texts.FontInfo; stylename, pstylename: ARRAY 64 OF CHAR; link : Texts.Link; PROCEDURE Error(CONST x : ARRAY OF CHAR); BEGIN KernelLog.String("Bluebottle Decoder Error: "); KernelLog.String(x); KernelLog.Ln; errors := TRUE END Error; PROCEDURE GetUTF8Char(r : Streams.Reader; VAR u : Texts.Char32; VAR pos : LONGINT) : BOOLEAN; VAR ch : ARRAY 8 OF CHAR; i : LONGINT; BEGIN ch[0] := r.Get(); INC(pos); FOR i := 1 TO ORD(UTF8Strings.CodeLength[ORD(ch[0])]) - 1 DO ch[i] := r.Get(); INC(pos) END; i := 0; RETURN UTF8Strings.DecodeChar(ch, i, u) END GetUTF8Char; PROCEDURE InsertPiece(charContent : XML.CDataSect); VAR i, m, tpos: LONGINT; res : WORD; ch, last : Texts.Char32; tempUCS32 : ARRAY 1024 OF Texts.Char32; oldpos, len : LONGINT; r, sr : Streams.StringReader; token : ARRAY 256 OF CHAR; tempInt: LONGINT; buffer : Strings.String; char : CHAR; cStyle : Texts.CharacterStyle; pStyle : Texts.ParagraphStyle; BEGIN m := LEN(tempUCS32) - 1; buffer := charContent.GetStr(); NEW(r, LEN(buffer^)); r.Set(buffer^); oldpos := text.GetLength(); len := charContent.GetLength(); tpos := 0; REPEAT IF GetUTF8Char(r, ch, tpos) THEN IF i = m THEN tempUCS32[i] := 0; text.InsertUCS32(text.GetLength(), tempUCS32); i := 0 END; IF (last # ORD(CR)) OR (ch # ORD(LF)) THEN IF ch = ORD(CR) THEN tempUCS32[i] := ORD(LF) ELSE tempUCS32[i] := ch END; INC(i) END; last := ch; END UNTIL (tpos >= len) OR (r.res # Streams.Ok); tempUCS32[i] := 0; text.InsertUCS32(text.GetLength(), tempUCS32); (* get style from the System *) cStyle := Texts.GetCharacterStyleByName(stylename); pStyle := Texts.GetParagraphStyleByName(pstylename); (* set attributes to emulate style in non-style supporting applications *) IF (attr = NIL) THEN NEW(attr); END; attr.voff := 0; attr.color := 0000000FFH; attr.bgcolor := 000000000H; IF (attr.fontInfo = NIL) THEN NEW(fi); attr.fontInfo := fi; END; attr.fontInfo.name := "Oberon"; attr.fontInfo.size := 10; attr.fontInfo.style := {}; IF (stylename = "Bold") THEN attr.fontInfo.style := {0}; ELSIF (stylename = "Highlight") THEN attr.fontInfo.style := {1}; ELSIF (stylename = "Assertion") THEN attr.fontInfo.style := {0}; attr.color := 00000FFFFH; ELSIF (stylename = "Debug") THEN attr.color := 00000FFFFH; ELSIF (stylename = "Lock") THEN attr.color := LONGINT(0FF00FFFFH); ELSIF (stylename = "Stupid") THEN attr.color := LONGINT(0FF0000FFH); ELSIF (stylename = "Comment") THEN attr.color := LONGINT(0808080FFH); ELSIF (stylename = "Preferred") THEN attr.fontInfo.style := {0}; attr.color := LONGINT(0800080FFH); ELSIF Strings.Match("AdHoc*", stylename) THEN NEW(sr, LEN(stylename)); sr.Set(stylename); sr.SkipWhitespace; sr.Token(token); (* AdHoc *) sr.SkipWhitespace; sr.Token(token); COPY(token, attr.fontInfo.name); (* family *) sr.SkipWhitespace; sr.Token(token); Strings.StrToInt(token, attr.fontInfo.size); (* size *) sr.SkipWhitespace; sr.Token(token); Strings.StrToInt(token, tempInt); (* style *) IF (tempInt = 0) THEN attr.fontInfo.style := {}; ELSIF (tempInt = 1) THEN attr.fontInfo.style := {0}; ELSIF (tempInt = 2) THEN attr.fontInfo.style := {1}; ELSIF (tempInt = 3) THEN attr.fontInfo.style := {0,1}; ELSE attr.fontInfo.style := {}; END; sr.SkipWhitespace; sr.Token(token); Strings.StrToInt(token, attr.voff); (* voff *) sr.SkipWhitespace; sr.Token(token); Strings.HexStrToInt(token, attr.color, res); (* color *) sr.SkipWhitespace; sr.Token(token); Strings.HexStrToInt(token, attr.bgcolor, res); (* bgcolor *) (* add Ad-Hoc style to the System in case it was not present already *) IF cStyle = NIL THEN NEW(cStyle); COPY(stylename, cStyle.name); COPY(attr.fontInfo.name, cStyle.family); cStyle.size := FP1616.FloatToFixp(attr.fontInfo.size); cStyle.style := attr.fontInfo.style; cStyle.baselineShift := attr.voff; cStyle.color := attr.color; cStyle.bgColor := attr.bgcolor; Texts.AddCharacterStyle(cStyle); END; ELSE (* Get the attributes from the style for compatibility *) IF (cStyle # NIL) THEN attr := StyleToAttribute(cStyle) ELSE token := "Style not present in System: "; Strings.Append(token, stylename); Error(token); END; END; text.SetAttributes(oldpos, text.GetLength()-oldpos, attr.Clone()); (* set the style for style supporting applications *) text.SetCharacterStyle(oldpos, text.GetLength()-oldpos, cStyle); (* Get AdHoc paragraph style & add to system *) IF Strings.Match("AdHoc*", pstylename) & (pStyle = NIL) THEN NEW(pStyle); NEW(sr, LEN(pstylename)); sr.Set(pstylename); sr.SkipWhitespace; sr.Token(token); COPY(pstylename, pStyle.name); (* AdHoc *) sr.SkipWhitespace; sr.Token(token); Strings.StrToInt(token, tempInt); pStyle.alignment := tempInt; (* alignment *) sr.SkipWhitespace; sr.Token(token); Strings.StrToInt(token, tempInt); pStyle.firstIndent := FP1616.FloatToFixp(tempInt); (* first Indent *) sr.SkipWhitespace; sr.Token(token); Strings.StrToInt(token, tempInt); pStyle.leftIndent := FP1616.FloatToFixp(tempInt); (* left Indent *) sr.SkipWhitespace; sr.Token(token); Strings.StrToInt(token, tempInt); pStyle.rightIndent := FP1616.FloatToFixp(tempInt); (* right Indent *) sr.SkipWhitespace; sr.Token(token); Strings.StrToInt(token, tempInt); pStyle.spaceBefore := FP1616.FloatToFixp(tempInt); (* space above *) sr.SkipWhitespace; sr.Token(token); Strings.StrToInt(token, tempInt); pStyle.spaceAfter := FP1616.FloatToFixp(tempInt); (* space below *) sr.SkipWhitespace; char := sr.Peek(); IF (char = "t") THEN sr.SkipBytes(1); sr.RawString(token); COPY(token, pStyle.tabStops); END; (* tabstops *) Texts.AddParagraphStyle(pStyle); END; (* set the paragraph style *) IF (pStyle # NIL) THEN text.SetParagraphStyle(oldpos, text.GetLength()-oldpos, pStyle) END; (* set the link *) text.SetLink(oldpos, text.GetLength()-oldpos, link); END InsertPiece; PROCEDURE InsertChar(pos : LONGINT; ch : Texts.Char32); VAR bufUCS32 : ARRAY 2 OF Texts.Char32; oldpos : LONGINT; cStyle : Texts.CharacterStyle; pStyle : Texts.ParagraphStyle; BEGIN bufUCS32[0] := ch; bufUCS32[1] := 0; oldpos := text.GetLength(); text.InsertUCS32(pos, bufUCS32); (* cursor moves automagically *) (* get style from the System *) cStyle := Texts.GetCharacterStyleByName(stylename); pStyle := Texts.GetParagraphStyleByName(pstylename); (* set the character style *) IF (cStyle # NIL) THEN text.SetCharacterStyle(oldpos, text.GetLength()-oldpos, cStyle) END; (* set the paragraph style *) IF (pStyle # NIL) THEN text.SetParagraphStyle(oldpos, text.GetLength()-oldpos, pStyle) END; (* set the link *) IF (link # NIL) THEN text.SetLink(oldpos, text.GetLength()-oldpos, link); KernelLog.String("bonk"); END; END InsertChar; PROCEDURE MalformedXML(pos, line, row: LONGINT; CONST msg: ARRAY OF CHAR); BEGIN Error(msg); END MalformedXML; PROCEDURE Open*(in : Streams.Reader; VAR res : WORD); VAR scanner : XMLScanner.Scanner; parser : XMLParser.Parser; d : XML.Document; BEGIN res := -1; errors := FALSE; IF in = NIL THEN Error("Input Stream is NIL"); RETURN; END; NEW(scanner, in); NEW(parser, scanner); parser.elemReg := Repositories.registry; parser.reportError := MalformedXML; d := parser.Parse(); IF errors THEN RETURN END; OpenXML(d); res := 0; END Open; PROCEDURE OpenXML*(d : XML.Document); VAR lp : Texts.LabelPiece; BEGIN errors := FALSE; doc := d; NEW(text); text.AcquireWrite; NEW(attr); root := doc.GetRoot(); cont := root.GetContents(); cont.Reset(); WHILE cont.HasMoreElements() DO ptr := cont.GetNext(); IF ptr IS XML.Element THEN str := ptr(XML.Element).GetName(); IF (str # NIL) & (str^ = "Label") THEN str := ptr(XML.Element).GetAttributeValue("name"); IF str # NIL THEN NEW(lp); lp.label := Strings.NewString(str^); text.InsertPiece(text.GetLength(), lp) END; ELSIF (str # NIL) & (str^ = "Paragraph") THEN tc := ptr(XML.Element).GetContents(); tc.Reset(); str := ptr(XML.Element).GetAttributeValue("style"); IF str # NIL THEN COPY(str^, pstylename); END; WHILE tc.HasMoreElements() DO ptr := tc.GetNext(); IF ptr IS XML.Element THEN str := ptr(XML.Element).GetName(); IF (str # NIL) & (str^ = "Label") THEN str := ptr(XML.Element).GetAttributeValue("name"); IF str # NIL THEN NEW(lp); lp.label := Strings.NewString(str^); text.InsertPiece(text.GetLength(), lp) END; ELSIF (str # NIL) & (str^ = "Span") THEN tc2 := ptr(XML.Element).GetContents(); tc2.Reset(); str := ptr(XML.Element).GetAttributeValue("style"); IF str # NIL THEN COPY(str^, stylename); END; str := ptr(XML.Element).GetAttributeValue("link"); IF str # NIL THEN NEW(link, LEN(str^)); COPY(str^, link^); ELSE link := NIL; END; WHILE tc2.HasMoreElements() DO ptr := tc2.GetNext(); IF ptr IS XML.CDataSect THEN InsertPiece(ptr(XML.CDataSect)) END; END; ELSIF (str # NIL) & (str^ = "Object") THEN tc2 := ptr(XML.Element).GetContents(); tc2.Reset(); IF tc2.HasMoreElements() THEN NEW(o); o.object := tc2.GetNext(); text.InsertPiece(text.GetLength(), o); END END END END; (* Insert a newline to finish paragraph *) (* InsertChar(text.GetLength(), Texts.NewLineChar); *) ELSIF (str # NIL) & (str^ = "Span") THEN COPY("Left", pstylename); tc := ptr(XML.Element).GetContents(); tc.Reset(); str := ptr(XML.Element).GetAttributeValue("style"); IF str # NIL THEN COPY(str^, stylename); END; str := ptr(XML.Element).GetAttributeValue("link"); IF str # NIL THEN NEW(link, LEN(str^)); COPY(str^, link^); ELSE link := NIL; END; WHILE tc.HasMoreElements() DO ptr := tc.GetNext(); IF ptr IS XML.CDataSect THEN InsertPiece(ptr(XML.CDataSect)) END; END ELSIF (str # NIL) & (str^ = "Object") THEN tc := ptr(XML.Element).GetContents(); tc.Reset(); IF tc.HasMoreElements() THEN NEW(o); o.object := tc.GetNext(); text.InsertPiece(text.GetLength(), o); END; END; END END; text.ReleaseWrite; END OpenXML; PROCEDURE GetText*() : Texts.Text; BEGIN RETURN text; END GetText; END BluebottleDecoder; BluebottleEncoder = OBJECT(Codecs.TextEncoder) VAR out: Streams.Writer; ch :Texts.Char32; r: Texts.TextReader; changed, pchanged, pOpen : BOOLEAN; stylename, pstylename: ARRAY 256 OF CHAR; cStyle: Texts.CharacterStyle; pStyle: Texts.ParagraphStyle; link : Texts.Link; (* hStyle: Texts.HighlightStyle; <-- TO DO *) (* Attributes attributes *) family, dfFamily : ARRAY 64 OF CHAR; size, dfSize : LONGINT; style, dfStyle : LONGINT; (* 0 = regular; 1 = bold; 2 = italic; 3 = bold-italic *) voff, dfVoff : LONGINT; color, dfColor : LONGINT; bgcolor, dfBgcolor : LONGINT; (* Set the default attribute values *) PROCEDURE Init; BEGIN dfFamily := "Oberon"; dfSize := 10; dfStyle := 0; dfVoff := 0; dfColor := 0000000FFH; dfBgcolor := 000000000H; END Init; (* extract the attributes from the current textreader *) PROCEDURE RetrieveAttributes; VAR tempstring, string: ARRAY 128 OF CHAR; BEGIN (* Get Character Style if any *) IF (r.cstyle # NIL) THEN cStyle := r.cstyle; COPY(cStyle.name, stylename); COPY(cStyle.family, family); size := cStyle.size; IF (cStyle.style = {}) THEN style := 0; ELSIF (cStyle.style = {0}) THEN style := 1; ELSIF (cStyle.style = {1}) THEN style := 2; ELSIF (cStyle.style = {0,1}) THEN style := 3; ELSE style := 0; END; voff := cStyle.baselineShift; color := cStyle.color; bgcolor := cStyle.bgColor; ELSE cStyle := NIL; (* Get attributes from char *) IF (r.font = NIL) THEN (* Fix missing values *) family := dfFamily; size := dfSize; style := dfStyle; ELSE COPY(r.font.name, family); size := r.font.size; IF (r.font.style = {}) THEN style := 0; ELSIF (r.font.style = {0}) THEN style := 1; ELSIF (r.font.style = {1}) THEN style := 2; ELSIF (r.font.style = {0,1}) THEN style := 3; ELSE style := 0; END; END; voff := r.voff; color := r.color; bgcolor := r.bgcolor; (* Find appropriate style *) IF (color = 0000000FFH) & (style = 0) THEN stylename := "Normal" ELSIF (color = 0000000FFH) & (style = 1) THEN stylename := "Bold" ELSIF (color = 0000000FFH) & (style = 2) THEN stylename := "Highlight" ELSIF ((color = 00000FFFFH) OR (color = 00000AAFFH)) & (style = 1) THEN stylename := "Assertion" ELSIF (color = 00000FFFFH) & (style = 0) THEN stylename := "Debug" ELSIF (color = 0FF00FFFFH) & (style = 0) THEN stylename := "Lock" ELSIF (color = 0FF0000FFH) & (style = 0) THEN stylename := "Stupid" ELSIF ((color = 0808080FFH) OR (color = 08A8A8AFFH)) & (style = 0) THEN stylename := "Comment" ELSIF (color = 0800080FFH) & (style = 1) THEN stylename := "Preferred" ELSE tempstring := "AdHoc"; Strings.Append(tempstring, " "); Strings.Append(tempstring, family); Strings.Append(tempstring, " "); Strings.IntToStr(size, string); Strings.Append(tempstring, string); Strings.Append(tempstring, " "); Strings.IntToStr(style, string); Strings.Append(tempstring, string); Strings.Append(tempstring, " "); Strings.IntToStr(voff, string); Strings.Append(tempstring, string); Strings.Append(tempstring, " "); Strings.IntToHexStr(color,7, string); Strings.Append(tempstring, string); Strings.Append(tempstring, " "); Strings.IntToHexStr(bgcolor,7, string); Strings.Append(tempstring, string); COPY(tempstring, stylename); (* KernelLog.String("Writing Ad-hoc Style: "); KernelLog.String(tempstring); KernelLog.Ln; *) END; END; (* Get Paragraph Style if any *) IF (r.pstyle # NIL) THEN pStyle := r.pstyle; COPY(pStyle.name, pstylename) ELSE pStyle := NIL; COPY("", pstylename) END; (* Get Link if any *) IF (r.link # NIL) THEN link := r.link; ELSE link := NIL; END; END RetrieveAttributes; PROCEDURE PrintAttributes; BEGIN KernelLog.String("# family: "); KernelLog.String(family); KernelLog.Ln; KernelLog.String("# size: "); KernelLog.Int(size, 0); KernelLog.Ln; KernelLog.String("# style: "); KernelLog.Int(style, 0); KernelLog.Ln; KernelLog.String("# voff: "); KernelLog.Int(voff, 0); KernelLog.Ln; KernelLog.String("# color: "); KernelLog.Hex(color, 0); KernelLog.Ln; KernelLog.String("# bgcolor: "); KernelLog.Hex(bgcolor, 0); KernelLog.Ln; END PrintAttributes; (* Return TRUE if current textreader attributes don't match the chached one *) PROCEDURE CompareAttributes():BOOLEAN; VAR tempstyle: LONGINT; isEqual : BOOLEAN; BEGIN IF (link = r.link) THEN IF r.cstyle # NIL THEN isEqual := (stylename = r.cstyle.name); RETURN ~isEqual; ELSE IF (r.font = NIL) THEN isEqual := (family = dfFamily) & (size = dfSize) & (style = dfStyle) & (voff = r.voff) & (color = r.color) & (bgcolor = r.bgcolor); ELSE IF (r.font.style = {}) THEN tempstyle := 0; ELSIF (r.font.style = {0}) THEN tempstyle := 1; ELSIF (r.font.style = {1}) THEN tempstyle := 2; ELSIF (r.font.style = {0,1}) THEN tempstyle := 3; ELSE tempstyle := 0; END; isEqual := (family = r.font.name) & (size = r.font.size) & (style = tempstyle) & (voff = r.voff) & (color = r.color) & (bgcolor = r.bgcolor); END; RETURN ~isEqual; END; ELSE RETURN TRUE; END END CompareAttributes; (* Return TRUE if current textreader paragraphstyle doesn't match the chached one *) PROCEDURE CompareParagraphs(): BOOLEAN; VAR isEqual : BOOLEAN; BEGIN IF r.pstyle # NIL THEN isEqual := (pstylename = r.pstyle.name); RETURN ~isEqual ELSIF (r.pstyle = NIL) & (pStyle = NIL) THEN RETURN FALSE; ELSE RETURN TRUE; END; END CompareParagraphs; PROCEDURE WriteParagraph(CONST name : ARRAY OF CHAR); BEGIN pOpen := TRUE; out.String("") END WriteParagraph; PROCEDURE CloseParagraph; BEGIN IF pOpen THEN out.String(""); pOpen := FALSE; END; END CloseParagraph; PROCEDURE WriteSpan(CONST name: ARRAY OF CHAR); BEGIN out.String(""); END CloseSpan; PROCEDURE WriteObject(o : ANY); BEGIN out.Ln; out.String(""); IF (o # NIL) & (o IS XML.Element) THEN o(XML.Element).Write(out, NIL, 1); END; out.String("");out.Ln; END WriteObject; PROCEDURE WriteLabel(CONST label: ARRAY OF CHAR); BEGIN out.String("