← Back to branch summary

~ubuntu-branches/ubuntu/dapper/fpc/dapper

« back to all changes in this revision

Viewing changes to fcl/classes/twriter.inc

  • Committer: Bazaar Package Importer
  • Author(s): Carlos Laviola
  • Date: 2004-08-12 16:29:37 UTC
  • mfrom: (1.2.1 upstream) (2.1.1 warty)
  • Revision ID: james.westby@ubuntu.com-20040812162937-moo8ulvysp1ln771
Tags: 1.9.4-5
http://bugs.debian.org/265265
fp-compiler: needs ld, adding dependency on binutils.  (Closes: #265265)

Show diffs side-by-side

added added

removed removed

Lines of Context:
fcl/classes/twriter.inc
 
1
{
 
2
    $Id: twriter.inc,v 1.1 2003/10/06 20:33:58 peter Exp $
 
3
    This file is part of the Free Component Library (FCL)
 
4
    Copyright (c) 1999-2000 by Michael Van Canneyt and Florian Klaempfl
 
5
 
 
6
    See the file COPYING.FPC, included in this distribution,
 
7
    for details about the copyright.
 
8
 
 
9
    This program is distributed in the hope that it will be useful,
 
10
    but WITHOUT ANY WARRANTY; without even the implied warranty of
 
11
    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
 
12
 
 
13
 **********************************************************************}
 
14
 
 
15
(*Procedure TTextWriter.WriteLn(Const Msg : String);
 
16
 
 
17
Const CRLF = #10;
 
18
 
 
19
begin
 
20
  Write(Msg+CRLF);
 
21
end;
 
22
 
 
23
Procedure TTextWriter.Write(Const Msg : String);
 
24
 
 
25
Var S : String;
 
26
 
 
27
begin
 
28
  S:=FPrefix+Msg;
 
29
  FStream.Write(Pointer(S)^,Length(S));
 
30
end;
 
31
 
 
32
 
 
33
Procedure TTextWriter.WriteFmt(Fmt : String; Args :  Array of const);
 
34
 
 
35
begin
 
36
  Writeln(Format(Fmt,Args));
 
37
end;
 
38
 
 
39
Procedure TTextWriter.StartObject(Const AClassName, AName : String);
 
40
 
 
41
begin
 
42
  WriteFmt('Object %s %s',[AName,AClassName]);
 
43
  FPrefix:=FPrefix+'  ';
 
44
end;
 
45
 
 
46
Procedure TTextWriter.EndObject;
 
47
 
 
48
Var L : longint;
 
49
 
 
50
begin
 
51
  L:=Length(FPrefix);
 
52
  If L>2 Then
 
53
    SetLength(FPrefix,L-2);
 
54
  Writeln('end');
 
55
end;
 
56
 
 
57
Procedure TTextWriter.StartCollection(Const AName : String);
 
58
 
 
59
begin
 
60
  WriteFmt('%s = (',[AName]);
 
61
  FPrefix:=FPrefix+'  ';
 
62
end;
 
63
 
 
64
Procedure TTextWriter.StartCollectionItem;
 
65
 
 
66
begin
 
67
end;
 
68
 
 
69
Procedure TTextWriter.EndCollectionItem;
 
70
 
 
71
begin
 
72
end;
 
73
 
 
74
Procedure TTextWriter.EndCollection;
 
75
 
 
76
Var L : longint;
 
77
 
 
78
begin
 
79
  L:=Length(FPrefix);
 
80
  If L>2 Then
 
81
    SetLength(FPrefix,L-2);
 
82
  Writeln(')');
 
83
end;
 
84
 
 
85
 
 
86
Procedure TTextWriter.WritePropName(const PropName: string);
 
87
 
 
88
begin
 
89
  Writeln(PropName);
 
90
end;
 
91
 
 
92
Constructor TTextWriter.Create(S : TStream);
 
93
 
 
94
begin
 
95
  Inherited Create;
 
96
  FStream:=S;
 
97
  FPrefix:='';
 
98
end;
 
99
 
 
100
Destructor TTextWriter.Destroy;
 
101
 
 
102
begin
 
103
end;
 
104
 
 
105
Procedure TTextWriter.WriteIntegerProperty(Const Name : Shortstring;Value : Longint);
 
106
 
 
107
begin
 
108
  WriteFmt('%s = %d',[Name,Value]);
 
109
end;
 
110
 
 
111
Procedure TTextWriter.WriteSetProperty (Const Name : ShortString;Value : longint; BaseType : TTypeInfo);
 
112
 
 
113
begin
 
114
  //!! needs implementing.
 
115
  WriteFmt('%s = []',[Name]);
 
116
end;
 
117
 
 
118
Procedure TTextWriter.WriteEnumerationProperty (Const Name : ShortString;Value : Longint; Const EnumName : ShortSTring);
 
119
 
 
120
begin
 
121
  WriteFmt('%s = %s',[Name,EnumName])
 
122
end;
 
123
 
 
124
Procedure TTextWriter.WriteStringProperty(Const Name : ShortString; Const Value : String);
 
125
 
 
126
Type
 
127
  TMode = (quoted,unquoted);
 
128
 
 
129
Var
 
130
  Mode : TMode;
 
131
  S : String;
 
132
  I,L : Longint;
 
133
  c : char;
 
134
 
 
135
   Procedure Add (A : String);
 
136
 
 
137
   begin
 
138
     S:=S+A;
 
139
   end;
 
140
 
 
141
begin
 
142
  L:=Length(Value);
 
143
  Mode:=unquoted;
 
144
  S:=Name+' = ';
 
145
  For I:=1 to L do
 
146
    begin
 
147
    C:=Value[i];
 
148
    If (ord(C)>31) and (Ord(c)<=128) and (c<>'''') then
 
149
      begin
 
150
      If mode=Quoted then
 
151
        Add(c)
 
152
      else
 
153
        begin
 
154
        Add(''''+c);
 
155
        mode:=quoted
 
156
        end
 
157
      end
 
158
    else
 
159
      begin
 
160
      If Mode=quoted then
 
161
        begin
 
162
        Add('''');
 
163
        mode:=unquoted;
 
164
        end;
 
165
      Add(Format('#%d',[ord(c)]));
 
166
      end;
 
167
    If Length(S)>72 then
 
168
      begin
 
169
      if mode=quoted then
 
170
        Add ('''');
 
171
      Add('+');
 
172
      Writeln(S);
 
173
      Mode:=unQuoted;
 
174
      end;
 
175
    end;
 
176
 if mode=quoted then Add('''');
 
177
 Writeln(S);
 
178
end;
 
179
 
 
180
Procedure TTextWriter.WriteFloatProperty(Const Name : ShortString; Value : Extended);
 
181
 
 
182
begin
 
183
  WriteFmt('%s = %e',[Name,Value])
 
184
end;
 
185
 
 
186
Procedure TTextWriter.WriteCollectionProperty(Const Name : ShortString;Value : TCollection);
 
187
 
 
188
begin
 
189
 
 
190
end;
 
191
 
 
192
Procedure TTextWriter.WriteClassProperty(Instance : TPersistent;Propinfo :PPropInfo);
 
193
 
 
194
begin
 
195
end;
 
196
 
 
197
Procedure TTextWriter.WriteComponentProperty(Const Name : ShortSTring; Value : TComponent);
 
198
 
 
199
begin
 
200
  WriteFmt ('%s = %s',[Name,Value.Name]);
 
201
end;
 
202
 
 
203
Procedure TTextWriter.WriteNilProperty(Const Name : Shortstring);
 
204
 
 
205
begin
 
206
  system.Writeln(stderr,'Nil : ',Name);
 
207
  WriteFmt ('%s = Nil',[Name])
 
208
end;
 
209
 
 
210
Procedure TTextWriter.WriteMethodProperty(Const Name,AMethodName : ShortString);
 
211
 
 
212
begin
 
213
  WriteFmt ('%s = %s',[Name,AMethodName]);
 
214
end;*)
 
215
 
 
216
{
 
217
  $Log: twriter.inc,v $
 
218
  Revision 1.1  2003/10/06 20:33:58  peter
 
219
    * classes moved to rtl for 1.1
 
220
    * classes .inc and classes.pp files moved to fcl/classes for
 
221
      backwards 1.0.x compatiblity to have it in the fcl
 
222
 
 
223
  Revision 1.3  2002/09/07 15:15:26  peter
 
224
    * old logs removed and tabs fixed
 
225
 
 
226
}