[fpc-devel]dfm/lfm reader patch

[Colin Western]

I attach a patch for the rtl reader for dfm/lfm type files, in the hope 
that it might be useful. It fixes some problems with reading inherited 
forms, and implements reading utf8 strings (though it just discards 
everything other than the bottom eight bits). Both helped in reading 
some Delphi generated dfm files.

Colin
diff -uNr fpc/rtl/objpas/classes/classesh.inc fpc.w/rtl/objpas/classes/classesh.inc
--- fpc/rtl/objpas/classes/classesh.inc 2004-01-22 23:16:37.000000000 +0000
+++ fpc.w/rtl/objpas/classes/classesh.inc       2004-01-24 09:41:39.000000000 +0000
@@ -721,7 +721,7 @@
 
   TValueType = (vaNull, vaList, vaInt8, vaInt16, vaInt32, vaExtended,
     vaString, vaIdent, vaFalse, vaTrue, vaBinary, vaSet, vaLString,
-    vaNil, vaCollection, vaSingle, vaCurrency, vaDate, vaWString, vaInt64);
+    vaNil, vaCollection, vaSingle, vaCurrency, vaDate, vaWString, vaInt64, 
vaUTF8String);
 
   TFilerFlag = (ffInherited, ffChildPos, ffInline);
   TFilerFlags = set of TFilerFlag;
diff -uNr fpc/rtl/objpas/classes/classes.inc fpc.w/rtl/objpas/classes/classes.inc
--- fpc/rtl/objpas/classes/classes.inc  2004-01-11 12:55:31.000000000 +0000
+++ fpc.w/rtl/objpas/classes/classes.inc        2004-01-24 09:41:39.000000000 +0000
@@ -737,9 +737,45 @@
   begin
     len := Input.ReadByte;
     SetLength(Result, len);
-    Input.Read(Result[1], len);
+    if len > 0 then
+      Input.Read(Result[1], len);
   end;
 
+  function ReadUTF8Str: String;
+  var
+    len, f, t: Integer;
+  begin
+    len := Input.ReadDWord;
+    SetLength(Result, len);
+    if len > 0 then begin
+      Input.Read(Result[1], len);
+      { For now simply take bottom 8 bits of Unicode character }
+      t := 1;
+      f := 1;
+      while f <= len do begin
+        if (Ord(Result[f]) and $80) <> 0 then begin
+          if (Ord(Result[f]) and %11100000) = %11000000 then
+            Inc(f)
+          else if (Ord(Result[f]) and %11110000) = %11100000 then
+            Inc(f,2)
+          else if (Ord(Result[f]) and %11111000) = %11110000 then
+            Inc(f,3)
+          else if (Ord(Result[f]) and %11111100) = %11111000 then
+            Inc(f,4)
+          else if (Ord(Result[f]) and %11111110) = %11111100 then
+            Inc(f,5)
+          else
+            WriteLn('Bad UTF8 Sequence');
+          Result[t] := Char((Ord(Result[f]) and %111111) or ((Ord(Result[f-1]) and 
%11) shl 6));
+        end else
+          Result[t] := Result[f];
+        Inc(f);
+        Inc(t);
+      end;
+      SetLength(Result, t-1);
+    end;
+  end;
+  
   procedure ReadPropList(indent: String);
 
     procedure ProcessValue(ValueType: TValueType; Indent: String);
@@ -842,8 +878,15 @@
           end;
         {vaSingle: begin OutLn('!!Single!!'); exit end;
         vaCurrency: begin OutLn('!!Currency!!'); exit end;
-        vaDate: begin OutLn('!!Date!!'); exit end;
-        vaWString: begin OutLn('!!WString!!'); exit end;}
+        vaDate: begin OutLn('!!Date!!'); exit end;}
+        vaWString: begin
+            OutLn('!!WString!!');
+            exit
+          end;
+        vaUTF8String: begin
+            OutString(ReadUTF8Str);
+            OutLn('');
+          end;
         else
           Stop(IntToStr(Ord(ValueType)));
       end;
@@ -1067,14 +1110,15 @@
 
   procedure ProcessObject;
   var
-    IsInherited: Boolean;
+    Flags: Byte;
     ObjectName, ObjectType: String;
+    ChildPos: Integer;
   begin
     if parser.TokenSymbolIs('OBJECT') then
-      IsInherited := False
+      Flags :=0  { IsInherited := False }
     else begin
       parser.CheckTokenSymbol('INHERITED');
-      IsInherited := True;
+      Flags := 1; { IsInherited := True; }
     end;
     parser.NextToken;
     parser.CheckToken(toSymbol);
@@ -1087,6 +1131,19 @@
       ObjectName := ObjectType;
       ObjectType := parser.TokenString;
       parser.NextToken;
+      if parser.Token = '[' then begin
+        parser.NextToken;
+        ChildPos := parser.TokenInt;
+        parser.NextToken;
+        parser.CheckToken(']');
+        parser.NextToken;
+        Flags := Flags or 2;
+      end;
+    end;
+    if Flags <> 0 then begin
+      Output.WriteByte($f0 or Flags);
+      if (Flags and 2) <> 0 then
+        WriteInteger(ChildPos);
     end;
     WriteString(ObjectType);
     WriteString(ObjectName);
diff -uNr fpc/rtl/objpas/classes/reader.inc fpc.w/rtl/objpas/classes/reader.inc
--- fpc/rtl/objpas/classes/reader.inc   2003-12-17 22:27:20.000000000 +0000
+++ fpc.w/rtl/objpas/classes/reader.inc 2004-01-24 09:41:39.000000000 +0000
@@ -71,7 +71,7 @@
     Flags := TFilerFlags(Prefix and $0f);
     if ffChildPos in Flags then
     begin
-      ValueType := NextValue;
+      ValueType := ReadValue;
       case ValueType of
         vaInt8:
           AChildPos := ReadInt8;