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