1{
2    *********************************************************************
3    Copyright (C) 1997, 1998 Gertjan Schouten
4
5    See the file COPYING.FPC, included in this distribution,
6    for details about the copyright.
7
8    This program is distributed in the hope that it will be useful,
9    but WITHOUT ANY WARRANTY; without even the implied warranty of
10    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
11
12 **********************************************************************
13
14    System Utilities For Free Pascal
15}
16
17{
18
19This include file is used in 3 different places for the following functions:
20
21  Function Format (Const Fmt : AnsiString; const Args : Array of const; const FormatSettings: TFormatSettings) : AnsiString;
22  Function UnicodeFormat (Const Fmt : UnicodeString; const Args : Array of const; Const FormatSettings: TFormatSettings) : UnicodeString;
23  Function WideFormat (Const Fmt : WideString; const Args : Array of const; Const FormatSettings: TFormatSettings) : WideString;
24
25The header is different, but the function remains the same.
26It uses the following defines:
27
28  INWIDESTRING
29  INUNICODESTRING
30 (INANSISTRING is implicit)
31
32and relies on 2 macros:
33
34  TFormatString : one of unicodestring, widestring,ansistring
35  TFormatChar : one of unicodechar, widechar or ansichar
36
37}
38
39Var ChPos,OldPos,ArgPos,DoArg,Len : SizeInt;
40    Hs,ToAdd : TFormatString;
41    Index : SizeInt;
42    Width,Prec : Longint;
43    Left : Boolean;
44    Fchar : char;
45    vq : qword;
46
47  {
48    ReadFormat reads the format string. It returns the type character in
49    uppercase, and sets index, Width, Prec to their correct values,
50    or -1 if not set. It sets Left to true if left alignment was requested.
51    In case of an error, DoFormatError is called.
52  }
53
54  Function ReadFormat : Char;
55
56  Var Value : longint;
57
58    Procedure ReadInteger;
59
60    var
61      Code: Word;
62      ArgN: SizeInt;
63    begin
64      If Value<>-1 then exit; // Was already read.
65      OldPos:=ChPos;
66      While (ChPos<=Len) and
67            (Fmt[ChPos]<='9') and (Fmt[ChPos]>='0') do inc(ChPos);
68      If ChPos>len then
69        DoFormatError(feInvalidFormat,ansistring(Fmt));
70      If Fmt[ChPos]='*' then
71        begin
72
73        if Index=-1 then
74          ArgN:=Argpos
75        else
76        begin
77          ArgN:=Index;
78          Inc(Index);
79        end;
80
81        If (ChPos>OldPos) or (ArgN>High(Args)) then
82          DoFormatError(feInvalidFormat,ansistring(Fmt));
83
84        ArgPos:=ArgN+1;
85
86        case Args[ArgN].Vtype of
87          vtInteger: Value := Args[ArgN].VInteger;
88          vtInt64: Value := Args[ArgN].VInt64^;
89          vtQWord: Value := Args[ArgN].VQWord^;
90        else
91          DoFormatError(feInvalidFormat,ansistring(Fmt));
92        end;
93        Inc(ChPos);
94        end
95      else
96        begin
97        If (OldPos<ChPos) Then
98          begin
99          Val (Copy(Fmt,OldPos,ChPos-OldPos),value,code);
100          // This should never happen !!
101          If Code>0 then DoFormatError (feInvalidFormat,ansistring(Fmt));
102          end
103        else
104          Value:=-1;
105        end;
106    end;
107
108    Procedure ReadIndex;
109
110    begin
111      If Fmt[ChPos]<>':' then
112        ReadInteger
113      else
114        value:=0; // Delphi undocumented behaviour, assume 0, #11099
115      If Fmt[ChPos]=':' then
116        begin
117        If Value=-1 then DoFormatError(feMissingArgument,ansistring(Fmt));
118        Index:=Value;
119        Value:=-1;
120        Inc(ChPos);
121        end;
122{$ifdef fmtdebug}
123      Log ('Read index');
124{$endif}
125    end;
126
127    Procedure ReadLeft;
128
129    begin
130      If Fmt[ChPos]='-' then
131        begin
132        left:=True;
133        Inc(ChPos);
134        end
135      else
136        Left:=False;
137{$ifdef fmtdebug}
138      Log ('Read Left');
139{$endif}
140    end;
141
142    Procedure ReadWidth;
143
144    begin
145      ReadInteger;
146      If Value<>-1 then
147        begin
148        Width:=Value;
149        Value:=-1;
150        end;
151{$ifdef fmtdebug}
152      Log ('Read width');
153{$endif}
154    end;
155
156    Procedure ReadPrec;
157
158    begin
159      If Fmt[ChPos]='.' then
160        begin
161        inc(ChPos);
162          ReadInteger;
163        If Value=-1 then
164         Value:=0;
165        prec:=Value;
166        end;
167{$ifdef fmtdebug}
168      Log ('Read precision');
169{$endif}
170    end;
171
172{$ifdef INWIDEFORMAT}
173  var
174    FormatChar : TFormatChar;
175{$endif INWIDEFORMAT}
176
177  begin
178{$ifdef fmtdebug}
179    Log ('Start format');
180{$endif}
181    Index:=-1;
182    Width:=-1;
183    Prec:=-1;
184    Value:=-1;
185    inc(ChPos);
186    If Fmt[ChPos]='%' then
187      begin
188        Result:='%';
189        exit;                           // VP fix
190      end;
191    ReadIndex;
192    ReadLeft;
193    ReadWidth;
194    ReadPrec;
195{$ifdef INWIDEFORMAT}
196    FormatChar:=UpCase(UnicodeChar(Fmt[ChPos]));
197    if word(FormatChar)>255 then
198      ReadFormat:=#255
199    else
200      ReadFormat:=FormatChar;
201{$else INWIDEFORMAT}
202    ReadFormat:=Upcase(Fmt[ChPos]);
203{$endif INWIDEFORMAT}
204{$ifdef fmtdebug}
205    Log ('End format');
206{$endif}
207end;
208
209
210{$ifdef fmtdebug}
211Procedure DumpFormat (C : char);
212begin
213  Write ('Fmt : ',fmt:10);
214  Write (' Index : ',Index:3);
215  Write (' Left  : ',left:5);
216  Write (' Width : ',Width:3);
217  Write (' Prec  : ',prec:3);
218  Writeln (' Type  : ',C);
219end;
220{$endif}
221
222
223function Checkarg (AT : SizeInt;err:boolean):boolean;
224{
225  Check if argument INDEX is of correct type (AT)
226  If Index=-1, ArgPos is used, and argpos is augmented with 1
227  DoArg is set to the argument that must be used.
228}
229begin
230  result:=false;
231  if Index=-1 then
232    DoArg:=Argpos
233  else
234    DoArg:=Index;
235  ArgPos:=DoArg+1;
236  If (Doarg>High(Args)) or (Args[Doarg].Vtype<>AT) then
237   begin
238     if err then
239      DoFormatError(feInvalidArgindex,ansistring(Fmt));
240     dec(ArgPos);
241     exit;
242   end;
243  result:=true;
244end;
245
246begin
247  Result:='';
248  Len:=Length(Fmt);
249  ChPos:=1;
250  OldPos:=1;
251  ArgPos:=0;
252  While ChPos<=len do
253    begin
254    While (ChPos<=Len) and (Fmt[ChPos]<>'%') do
255      inc(ChPos);
256    If ChPos>OldPos Then
257      Result:=Result+Copy(Fmt,OldPos,ChPos-Oldpos);
258    If ChPos<Len then
259      begin
260      FChar:=ReadFormat;
261{$ifdef fmtdebug}
262      DumpFormat(FCHar);
263{$endif}
264      Case FChar of
265        'D' : begin
266              if Checkarg(vtinteger,false) then
267                Str(Args[Doarg].VInteger,ToAdd)
268              else if CheckArg(vtInt64,false) then
269                Str(Args[DoArg].VInt64^,toadd)
270              else if CheckArg(vtQWord,true) then
271                Str(int64(Args[DoArg].VQWord^),toadd);
272              Width:=Abs(width);
273              Index:=Prec-Length(ToAdd);
274              If ToAdd[1]<>'-' then
275                ToAdd:=TFormatString(StringOfChar('0',Index))+ToAdd
276              else
277                // + 1 to accomodate for - sign in length !!
278                Insert(TFormatString(StringOfChar('0',Index+1)),toadd,2);
279              end;
280        'U' : begin
281              if Checkarg(vtinteger,false) then
282                Str(cardinal(Args[Doarg].VInteger),ToAdd)
283              else if CheckArg(vtInt64,false) then
284                Str(qword(Args[DoArg].VInt64^),toadd)
285              else if CheckArg(vtQWord,true) then
286                Str(Args[DoArg].VQWord^,toadd);
287              Width:=Abs(width);
288              Index:=Prec-Length(ToAdd);
289              ToAdd:=TFormatString(StringOfChar('0',Index))+ToAdd
290              end;
291{$ifndef FPUNONE}
292        'E' : begin
293              if CheckArg(vtCurrency,false) then
294                ToAdd:=TFormatString(FloatToStrF(Args[doarg].VCurrency^,ffexponent,Prec,3,FormatSettings))
295              else if CheckArg(vtExtended,true) then
296                ToAdd:=TFormatString(FloatToStrF(Args[doarg].VExtended^,ffexponent,Prec,3,FormatSettings));
297              end;
298        'F' : begin
299              if CheckArg(vtCurrency,false) then
300                ToAdd:=TFormatString(FloatToStrF(Args[doarg].VCurrency^,ffFixed,9999,Prec,FormatSettings))
301              else if CheckArg(vtExtended,true) then
302                ToAdd:=TFormatString(FloatToStrF(Args[doarg].VExtended^,ffFixed,9999,Prec,FormatSettings));
303              end;
304        'G' : begin
305              if CheckArg(vtCurrency,false) then
306                ToAdd:=TFormatString(FloatToStrF(Args[doarg].VCurrency^,ffGeneral,Prec,3,FormatSettings))
307              else if CheckArg(vtExtended,true) then
308                ToAdd:=TFormatString(FloatToStrF(Args[doarg].VExtended^,ffGeneral,Prec,3,FormatSettings));
309              end;
310        'N' : begin
311              if CheckArg(vtCurrency,false) then
312                ToAdd:=TFormatString(FloatToStrF(Args[doarg].VCurrency^,ffNumber,9999,Prec,FormatSettings))
313              else if CheckArg(vtExtended,true) then
314                ToAdd:=TFormatString(FloatToStrF(Args[doarg].VExtended^,ffNumber,9999,Prec,FormatSettings));
315              end;
316        'M' : begin
317              if CheckArg(vtExtended,false) then
318                ToAdd:=TFormatString(FloatToStrF(Args[doarg].VExtended^,ffCurrency,9999,Prec,FormatSettings))
319              else if CheckArg(vtCurrency,true) then
320                ToAdd:=TFormatString(FloatToStrF(Args[doarg].VCurrency^,ffCurrency,9999,Prec,FormatSettings));
321              end;
322{$else}
323        'E','F','G','N','M':
324              RunError(207);
325{$endif}
326        'S' : begin
327                if CheckArg(vtString,false) then
328                  hs:=TFormatString(Args[doarg].VString^)
329                else
330                  if CheckArg(vtChar,false) then
331                    hs:=TFormatString(Args[doarg].VChar)
332                else
333                  if CheckArg(vtPChar,false) then
334                    hs:=TFormatString(Args[doarg].VPChar)
335                else
336                  if CheckArg(vtPWideChar,false) then
337                    hs:=TFormatString(WideString(Args[doarg].VPWideChar))
338                else
339                  if CheckArg(vtWideChar,false) then
340                    hs:=TFormatString(WideString(Args[doarg].VWideChar))
341                else
342                  if CheckArg(vtWidestring,false) then
343                    hs:=TFormatString(WideString(Args[doarg].VWideString))
344                else
345                  if CheckArg(vtAnsiString,false) then
346                    hs:=TFormatString(ansistring(Args[doarg].VAnsiString))
347                else
348                  if CheckArg(vtUnicodeString,false) then
349                    hs:=TFormatString(UnicodeString(Args[doarg].VUnicodeString))
350                else
351                  if CheckArg(vtVariant,true) then
352                    hs:=Args[doarg].VVariant^;
353                Index:=Length(hs);
354                If (Prec<>-1) and (Index>Prec) then
355                  Index:=Prec;
356                ToAdd:=Copy(hs,1,Index);
357              end;
358        'P' : Begin
359              CheckArg(vtpointer,true);
360              ToAdd:=TFormatString(HexStr(ptruint(Args[DoArg].VPointer),sizeof(Ptruint)*2));
361              // Insert ':'. Is this needed in 32 bit ? No it isn't.
362              // Insert(':',ToAdd,5);
363              end;
364        'X' : begin
365              if Checkarg(vtinteger,false) then
366                 begin
367                   vq:=Cardinal(Args[Doarg].VInteger);
368                   index:=16;
369                 end
370              else
371                 if CheckArg(vtQWord, false) then
372                   begin
373                     vq:=Qword(Args[DoArg].VQWord^);
374                     index:=31;
375                   end
376              else
377                 begin
378                   CheckArg(vtInt64,true);
379                   vq:=Qword(Args[DoArg].VInt64^);
380                   index:=31;
381                 end;
382              If Prec>index then
383                ToAdd:=TFormatString(HexStr(int64(vq),index))
384              else
385                begin
386                // determine minimum needed number of hex digits.
387                Index:=1;
388                While (qWord(1) shl (Index*4)<=vq) and (index<16) do
389                  inc(Index);
390                If Index>Prec then
391                  Prec:=Index;
392                ToAdd:=TFormatString(HexStr(int64(vq),Prec));
393                end;
394              end;
395        '%': ToAdd:='%';
396      end;
397      If Width<>-1 then
398        If Length(ToAdd)<Width then
399          If not Left then
400            ToAdd:=TFormatString(Space(Width-Length(ToAdd)))+ToAdd
401          else
402            ToAdd:=ToAdd+TFormatString(space(Width-Length(ToAdd)));
403      Result:=Result+ToAdd;
404      end;
405    inc(ChPos);
406    Oldpos:=ChPos;
407    end;
408end;
409