Articles   Members Online:
-Article/Tip Search
-News Group Search over 21 Million news group articles.
-Delphi/Pascal
-CBuilder/C++
-C#Builder/C#
-JBuilder/Java
-Kylix
Member Area
-Home
-Account Center
-Top 10 NEW!!
-Submit Article/Tip
-Forums Upgraded!!
-My Articles
-Edit Information
-Login/Logout
-Become a Member
-Why sign up!
-Newsletter
-Chat Online!
-Indexes NEW!!
Employment
-Build your resume
-Find a job
-Post a job
-Resume Search
Contacts
-Contacts
-Feedbacks
-Link to us
-Privacy/Disclaimer
Embarcadero
Visit Embarcadero
Embarcadero Community
JEDI
Links
Howt to extract string property values from DFM files Turn on/off line numbers in source code. Switch to Orginial background IDE or DSP color Comment or reply to this aritlce/tip for discussion. Bookmark this article to my favorite article(s). Print this article
06-Feb-03
Category
Object Pascal-Strings
Language
Delphi 2.x
Views
159
User Rating
No Votes
# Votes
0
Replies
0
Publisher:
DSP, Administrator
Reference URL:
DKB
			Author: Lou Adler

Does anybody know the name of the routine used in the IDE that enables control 
characters embedded into a string to be recognised. For example the characters 
'Line 1'#13#10'Line 2' are recognised by the compiler as a single string literal. 
I'd like to build a similar facility into an application. Is a single routine used 
for this or is it embedded somewhere in the parser of the compiler?

Answer:

I'm pretty sure that the compiler uses an internal routine for this which is not 
accessible to us mere mortals. Perhaps you can extract something useful from the 
unit below. I wrote it to extract string property values from DFM files. It is a 
work in progress, so if you want to use it for the same purpose be aware that you 
may have DFMs it will not be able to digest without modifications.

1   unit DFMParser;
2   
3   interface
4   
5   uses
6     classes, sysutils;
7   
8   type
9     TBaseParser = class
10    private
11      FText: string;
12      FCurrent, FAnchor: Integer;
13      FToken: string;
14    protected
15      procedure Error(const S: string); overload;
16      procedure Error(const fmt: string; const A: array of const); overload;
17      procedure DropAnchor;
18      procedure NextToken;
19      procedure NextChar;
20      procedure SkipWhitespace;
21      procedure SkipToEol;
22      procedure SkipTo(ch: Char);
23      procedure SkipToString(const S: string);
24      function EndOfText: Boolean;
25      function IsTokenChar: Boolean;
26      function IsWhiteSpace: Boolean;
27      function CurrentChar: Char;
28      function LastWord: string;
29      function ParseEncodedChar: Char;
30      function ParseQuotedString: string;
31      function ParseStringValue: string;
32    public
33      procedure Parse; virtual; abstract;
34      constructor Create(const S: string); virtual;
35      property Token: string read FToken;
36    end;
37  
38    TParsePropertyEvent = procedure(const aComponentName, aPropertyName,
39      aPropertyValue: string) of object;
40  
41    TDFMParser = class(TBaseParser)
42    private
43      FParsePropertyEvent: TParsePropertyEvent;
44    protected
45      procedure ParseComponent;
46      procedure ParseProperty(const componentName: string);
47      procedure ParsePropertyString(const componentName, propertyName: string);
48      function TokenIsObject: Boolean;
49      function IsEndToken: Boolean;
50      procedure DoPropertyEvent(const componentName, propertyname, propvalue: string);
51    public
52      procedure Parse; override;
53      property OnParseProperty: TParsePropertyEvent read FParsePropertyEvent
54        write FParsePropertyEvent;
55    end;
56  
57    EDFMParserError = class(Exception);
58  
59    TTranslationItemEvent = procedure(const name, value: string) of object;
60  
61    TTranslationParser = class(TBaseParser)
62    private
63      FTranslationItemEvent: TTranslationItemEvent;
64      procedure ParseStringConstant;
65      procedure SkipWhitespaceAndComments;
66      procedure DoTranslationItem(const name, value: string);
67    public
68      constructor Create(const S: string); override;
69      procedure Parse; override;
70      property OnTranslationItem: TTranslationItemEvent read FTranslationItemEvent
71        write FTranslationItemEvent;
72    end;
73  
74  implementation
75  
76  uses
77    charsets;
78  
79  const
80    quote = '''';
81  
82  constructor TBaseParser.Create(const S: string);
83  begin
84    FText := S;
85    FCurrent := 1;
86  end;
87  
88  function TBaseParser.CurrentChar: Char;
89  begin
90    result := FText[FCurrent];
91  end;
92  
93  procedure TBaseParser.DropAnchor;
94  begin
95    FAnchor := FCurrent;
96  end;
97  
98  function TBaseParser.EndOfText: Boolean;
99  begin
100   result := FCurrent > Length(FText);
101 end;
102 
103 procedure TBaseParser.Error(const S: string);
104 begin
105   raise EPArserError.Create(S);
106 end;
107 
108 procedure TBaseParser.Error(const fmt: string; const A: array of const);
109 begin
110   Error(Format(fmt, A));
111 end;
112 
113 function TBaseParser.IsTokenChar: Boolean;
114 begin
115   result := (Currentchar in Charsets.IdentifierChars) or (CurrentChar = '.');
116 end;
117 
118 function TBaseParser.IsWhiteSpace: Boolean;
119 begin
120   result := Currentchar in [#1..#32];
121 end;
122 
123 function TBaseParser.LastWord: string;
124 begin
125   Assert(FAnchor <= FCurrent);
126   result := Copy(FText, FAnchor, FCurrent - FAnchor);
127 end;
128 
129 procedure TBaseParser.NextChar;
130 begin
131   Inc(FCurrent);
132   if EndOfText then
133     Error('Unexpected end of text');
134 end;
135 
136 procedure TBaseParser.NextToken;
137 begin
138   SkipWhitespace;
139   DropAnchor;
140   while not EndOfText and IsTokenChar do
141     Inc(FCurrent);
142   FToken := LastWord;
143 end;
144 
145 procedure TBaseParser.SkipTo(ch: Char);
146 begin
147   while not EndOfText and (Currentchar <> ch) do
148     NextChar;
149   Inc(FCurrent);
150 end;
151 
152 procedure TBaseParser.SkipToString(const S: string);
153 var
154   P: PChar;
155 begin
156   p := StrPos(@FText[FCurrent], Pchar(S));
157   if Assigned(p) then
158     FCurrent := p - PChar(FText) + 1 + Length(S)
159   else
160     Error('Expected string "%s" not found', [s]);
161 end;
162 
163 procedure TBaseParser.SkipToEol;
164 begin
165   while not EndOfText and (FText[FCurrent] <> #10) do
166     Inc(FCurrent);
167 end;
168 
169 procedure TBaseParser.SkipWhitespace;
170 begin
171   while not EndOfText and IsWhiteSpace do
172     Inc(FCurrent);
173 end;
174 
175 function TBaseParser.ParseQuotedString: string;
176 begin
177   Assert(CurrentChar = quote);
178   Result := '';
179   repeat
180     NextChar; {skip leading quote}
181     DropAnchor;
182     while CurrentChar <> quote do
183       NextChar;
184     Result := Result + LastWord;
185     NextChar;
186     if CurrentChar = quote then
187       Result := Result + quote; {literal quote}
188   until
189     CurrentChar <> quote;
190   SkipWhitespace;
191 end;
192 
193 function TBaseParser.ParseEncodedChar: Char;
194 var
195   allowed: Charsets.TCharset;
196   n: Integer;
197 begin
198   Assert(CurrentChar = '#');
199   NextChar;
200   DropAnchor;
201   if CurrentChar = '$' then
202   begin
203     allowed := CHarsets.HexNumerals;
204     NextChar;
205   end
206   else
207     allowed := Charsets.IntegerChars;
208   while CurrentChar in allowed do
209     NextChar;
210   n := StrToInt(LastWord);
211   if n > High(Byte) then
212     Error('Encountered UNICODE character in string, cannot handle that.');
213   Result := Char(n);
214 end;
215 
216 function TBaseParser.ParseStringValue: string;
217 begin
218   Result := '';
219   while True do
220     case CurrentChar of
221       quote:
222         Result := Result + ParseQuotedString;
223       '#':
224         Result := Result + ParseEncodedChar;
225       '+':
226         begin
227           NextChar;
228           SkipWhitespace;
229         end;
230     else
231       Break;
232     end;
233 end;
234 
235 { TDFMParser }
236 
237 procedure TDFMParser.DoPropertyEvent(const componentName, propertyname, propvalue:
238   string);
239 begin
240   if Assigned(FParsePropertyEvent) then
241     FParsePropertyEvent(componentName, propertyname, propvalue);
242 end;
243 
244 function TDFMParser.IsEndToken: Boolean;
245 begin
246   result := Token = 'end';
247 end;
248 
249 procedure TDFMParser.Parse;
250 begin
251   while not EndOfText do
252   begin
253     ParseComponent;
254     SkipWhitespace;
255   end;
256 end;
257 
258 procedure TDFMParser.ParseComponent;
259 var
260   componentName: string;
261 begin
262   if FToken = '' then
263     NextToken;
264   if not TokenIsObject then
265     Error('Expected: inherited or object, found : %s', [Token]);
266   NextToken;
267   componentName := Token;
268   SkipToEol;
269   repeat
270     NextToken;
271     if TokenIsObject then
272       ParseComponent
273     else if not IsEndToken then
274       ParseProperty(componentName);
275   until
276     IsEndToken or EndOfText;
277   if IsEndToken then
278     FToken := '';
279 end;
280 
281 procedure TDFMParser.ParseProperty(const componentName: string);
282 var
283   propname: string;
284 begin
285   propname := Token;
286   SkipWhitespace;
287   if CurrentChar <> '=' then
288     Error('Expected: =, found %s', [Currentchar]);
289   NextChar;
290   SkipWhitespace;
291   case CurrentChar of
292     '{':
293       SkipTo('}');
294     '(':
295       SkipTo(')');
296     '[':
297       SkipTo(']');
298     quote, '#':
299       ParsePropertyString(componentName, propname);
300   else
301     SkipToEol
302   end;
303 end;
304 
305 procedure TDFMParser.ParsePropertyString(const componentName, propertyName: string);
306 var
307   propvalue: string;
308 begin
309   propvalue := ParseStringValue;
310   if propvalue <> '' then
311     DoPropertyEvent(componentName, propertyname, propvalue);
312 end;
313 
314 function TDFMParser.TokenIsObject: Boolean;
315 begin
316   Result := (Token = 'inherited') or (Token = 'object')
317 end;
318 
319 { TTranslationParser }
320 
321 constructor TTranslationParser.Create(const S: string);
322 const
323   resStr = 'resourcestring';
324 var
325   lS: string;
326   resourceStringPos: Integer;
327   n1, n2: Integer;
328 begin
329   {Isolate the resourcestring section. We expect only one}
330   lS := LowerCase(S);
331   resourceStringPos := Pos(resStr, lS);
332   if resourceStringPos = 0 then
333     inherited Create('')
334   else
335   begin
336     {look for an $ifdef german}
337     n1 := Pos('{$ifdef german', lS);
338     if n1 > 0 then
339     begin
340       {look for the following $else}
341       Delete(lS, 1, n1 - 1);
342       n2 := Pos('{$else}', lS);
343       if n2 = 0 then
344         Error('Malformed $IFDEF...$ELSE encountered, $ELSE not found');
345       Delete(lS, 1, n2 - 1);
346       Inc(n1, n2 - 1);
347       {look for the $ENDIF}
348       n2 := Pos('{$endif}', lS);
349       if n2 = 0 then
350         Error('Malformed $IFDEF...$ENDIF encountered, $ENDIF not found');
351       inherited Create(Copy(S, n1, n2 - 1));
352     end
353     else
354     begin
355       {look for an $ifndef german}
356       n1 := Pos('{$ifndef german', lS);
357       if n1 = 0 then
358         inherited Create('')
359       else
360       begin
361         {in the $ifndef german construct the resourcestring keyword often comes 
362 after the $ifndef.}
363         if n1 < resourceStringPos then
364           n1 := resourceStringPos + Length(resstr);
365         Delete(lS, 1, n1 - 1);
366         {look for the $ENDIF}
367         n2 := Pos('{$endif}', lS);
368         if n2 = 0 then
369           Error('Malformed $IFDEF...$ENDIF encountered, $ENDIF not found');
370         inherited Create(Copy(S, n1, n2 - 1));
371       end;
372     end;
373   end;
374 end;
375 
376 procedure TTranslationParser.DoTranslationItem(const name, value: string);
377 begin
378   if Assigned(FTranslationItemEvent) then
379     FTranslationItemEvent(name, value);
380 end;
381 
382 procedure TTranslationParser.Parse;
383 begin
384   while not EndOfText do
385   begin
386     ParseStringConstant;
387     SkipWhitespace;
388   end;
389 end;
390 
391 procedure TTranslationParser.ParseStringConstant;
392 var
393   name, value: string;
394 begin
395   SkipWhitespaceAndComments;
396   if EndOfText then
397     Exit;
398   NextToken;
399   name := Token;
400   SkipWhitespaceAndComments;
401   if EndOfText then
402     Exit;
403   if CurrentChar <> '=' then
404     Error('Expected: =, found "%s"', [CurrentChar]);
405   NextChar;
406   SkipWhitespaceAndComments;
407   if EndOfText then
408     Exit;
409   value := ParseStringValue;
410   SkipWhiteSpace;
411   if not EndOfText and (CurrentChar = ';') then
412     NextChar;
413   DoTranslationItem(name, value);
414 end;
415 
416 procedure TTranslationParser.SkipWhitespaceAndComments;
417 begin
418   while True do
419   begin
420     SkipWhitespace;
421     if not EndOfText then
422     begin
423       case CurrentChar of
424         '/':
425           SkipToEol; { single line comment }
426         '{':
427           SkipTo('}'); { comment }
428         '(':
429           begin
430             NextChar;
431             if CurrentChar = '*' then
432               SkipToString('*)')
433             else
434               Error('Expected: comment or indentifier, found: "(%s"', 
435 [CurrentChar]);
436           end;
437       else
438         Break
439       end;
440     end
441     else
442       Break;
443   end;
444 end;
445 
446 end.
447 
448 unit Charsets;
449 
450 interface
451 
452 type
453   TCharSet = set of AnsiChar;
454 const
455   Signs: TCharset = ['-', '+'];
456   Numerals: TCharset = ['0'..'9'];
457   HexNumerals: TCharset = ['A'..'F', 'a'..'f', '0'..'9'];
458   IntegerChars: TCharset = ['0'..'9', '-', '+'];
459   IdentifierChars: TCharset = ['a'..'z', 'A'..'Z', '0'..'9', '_'];
460 var
461   Digits, Letters, LowerCaseLetters, UpperCaseLetters: TCharSet;
462   FloatChars, SciFloatChars: TCharset;
463   AlphaNum, NonAlphaNum: TCharset;
464 
465   { Need to call this again when locale changes.  }
466 procedure SetupCharsets;
467 
468 implementation
469 
470 uses
471   Windows, Sysutils;
472 
473 var
474   locale: DWORD = 0;
475 
476 procedure SetupCharsets;
477 var
478   ch: AnsiChar;
479 begin
480   if locale = GetThreadLocale then
481     Exit
482   else
483     Locale := GetThreadLocale;
484   LowerCaseLetters := [];
485   UpperCaseLetters := [];
486   AlphaNum := [];
487   NonAlphaNum := [];
488   Digits := Numerals;
489   for ch := Low(ch) to High(ch) do
490   begin
491     if IsCharAlpha(ch) then
492       if IsCharUpper(ch) then
493         Include(UpperCaseLetters, ch)
494       else
495         Include(LowerCaseLetters, ch);
496     if IsCharAlphanumeric(ch) then
497       Include(AlphaNum, ch)
498     else
499       Include(NonAlphaNum, ch);
500   end;
501   Letters := LowerCaseLetters + UpperCaseLetters;
502   FloatChars := IntegerChars;
503   Include(FloatChars, DecimalSeparator);
504   SciFloatChars := FloatChars + ['e', 'E'];
505 end;
506 
507 initialization
508   SetupCharsets;
509 end.


			
Vote: How useful do you find this Article/Tip?
Bad Excellent
1 2 3 4 5 6 7 8 9 10

 

Advertisement
Share this page
Advertisement
Download from Google

Copyright © Mendozi Enterprises LLC