sakurasuite/SsParser.pas

   1 {********************************************************}
   2 { TSsParser Component - Parser for Sakura Script         }
   3 {                                                        }
   4 {       Copyright (c) 2001-2003 naruto/CANO-Lab          }
   5 {********************************************************}
   6
   7 unit SsParser;
   8
   9 interface
  10
  11 uses
  12   Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs;
  13
  14 type
  15   // Kind of the Markup
  16   // mtTag:  Tag. (begins with \)
  17   // mtMeta: Meta expression. (begins with %)
  18   // mtTagErr: Seems to be a markup error
  19   // mtStr: Other normal talk string
  20   TSsMarkUpType = (mtTag, mtMeta, mtTagErr, mtStr);
  21
  22   // Intercepting the parsing
  23   TSsParseEvent = procedure (Sender: TObject; const Script: String;
  24     var Len: integer; var MarkType: TSsMarkUpType; var Extra: String) of object;
  25
  26   // Exception class
  27   ESsParserError = class(Exception);
  28
  29   TSsMarkUp = class(TObject)
  30   private
  31     FPos: integer;
  32     FExtra: String;
  33     FStr: String;
  34     FMarkUpType: TSsMarkUpType;
  35     procedure SetExtra(const Value: String);
  36   public
  37     constructor Create(Pos: integer; MarkUpType: TSsMarkUpType; Str: String; Extra: String = '');
  38     property Pos: integer read FPos; //This markup is Pos'th character in InputString
  39     property MarkUpType: TSsMarkUpType read FMarkUpType;
  40     property Str: String read FStr;
  41     property Extra: String read FExtra write SetExtra;
  42   end;
  43
  44   TSsParser = class(TComponent)
  45   private
  46     FTagPattern: TStrings;    //SakuraScript tag pattern string
  47     FMetaPattern: TStrings;   //SakuraScript meta expression pattern string
  48     FInputString: String;
  49     FMarkUpList: TList;
  50     FLeaveEscape: boolean;
  51     FEscapeInvalidMeta: boolean;
  52     FOnParse: TSsParseEvent;
  53     procedure SetInputString(const Value: String);
  54     function GetCount: integer;
  55     function GetExtra(Index: integer): String;
  56     function GetMarkUpType(Index: integer): TSsMarkUpType;
  57     function GetStr(Index: integer): String;
  58     procedure SetExtra(Index: integer; const Value: String);
  59     procedure ClearList;
  60     procedure SetMetaPattern(const Value: TStrings);
  61     procedure SetTagPattern(const Value: TStrings);
  62     procedure SetOnParse(const Value: TSsParseEvent);
  63     function GetFirstChar(const Str: String): String;
  64     function ChopFirstChar(var Str: String): String;
  65     function GetPosition(Index: integer): integer;
  66   protected
  67     procedure BeginParse;
  68   public
  69     constructor Create(AOwner: TComponent); override;
  70     destructor Destroy; override;
  71     function MatchP(PStr, PPattern: PChar): integer;
  72     function Match(Str, Pattern: String): integer;
  73     function GetParam(Tag: String; const Index: integer): String;
  74     function EscapeParam(const Param: String): String;
  75     function MarkUpAt(const Pos: integer): integer;
  76
  77     property Count: integer read GetCount;
  78     property MarkUpType[Index: integer]: TSsMarkUpType read GetMarkUpType;
  79     property Str[Index: integer]: String read GetStr; default;
  80     property Extra[Index: integer]: String read GetExtra write SetExtra;
  81     property Position[Index: integer]: integer read GetPosition;
  82     property InputString: String read FInputString write SetInputString;
  83   published
  84     // Script parsing patterns.
  85     property TagPattern: TStrings read FTagPattern write SetTagPattern;
  86     property MetaPattern: TStrings read FMetaPattern write SetMetaPattern;
  87     // Whether to leave escape sequence "\\" and "\%" in mtStr elements
  88     property LeaveEscape: boolean read FLeaveEscape write FLeaveEscape
  89       default true;
  90     // Replace '%' to '\%' if sequence follwing the '%' could not
  91     // be parsed as a meta expression
  92     property EscapeInvalidMeta: boolean read FEscapeInvalidMeta
  93       write FEscapeInvalidMeta default false;
  94     // Component users can intercept and handle part of the parsing using this event.
  95     property OnParse: TSsParseEvent read FOnParse write SetOnParse;
  96   end;
  97
  98 procedure Register;
  99
 100 implementation
 101
 102 resourcestring
 103   CElementTypeError = '\90³\82µ\82¢\83G\83\8c\83\81\83\93\83g\83^\83C\83v\82ð\95Ô\82µ\82Ä\82\82¾\82³\82¢';
 104   CTagPatternSyntaxError = 'TagPattern\95\\8bL\83~\83X %d \8ds\96Ú';
 105   CMarkupIndexOutofRange = '\83C\83\93\83f\83b\83N\83X\82ª\94Í\88Í\82ð\82±\82¦\82Ä\82¢\82Ü\82·';
 106
 107 {
 108   // English error message
 109   CElementTypeError = 'Returned element type is invalid in OnParse.';
 110   CTagPatternSyntaxError = 'TagPattern syntax error at line %d.';
 111   CMarkupIndexOutofRange = 'Markup index if out of range.';
 112 }
 113
 114
 115 procedure Register;
 116 begin
 117   RegisterComponents('Samples', [TSsParser]);
 118 end;
 119
 120 { TSsParser }
 121
 122 procedure TSsParser.BeginParse;
 123 var Str, Talk, T, Ex: String;
 124     i, Le: integer;
 125     IsErr: boolean;
 126     Mt: TSsMarkUpType;
 127     PStr: PChar;
 128 begin
 129   ClearList;
 130   Str := FInputString; // The string to be parsed from now
 131   // This is to avoid access violation if `Str` is terminated
 132   // with DBCS leadbyte. (Such string is invalid from the beginning of course)
 133   Str := Str + #0#0;
 134   if Length(Str) = 0 then Exit;
 135   PStr := PChar(Str);
 136   Talk := '';
 137   while PStr^ <> #0 do begin
 138     if PStr^ = '\' then begin
 139       Inc(PStr);
 140       if PStr^ = '\' then
 141       begin
 142         // Escaped sequence "\\"
 143         if FLeaveEscape then
 144           Talk := Talk + '\\'
 145         else
 146           Talk := Talk + '\';
 147         Inc(PStr);
 148         Continue;
 149       end else if PStr^ = '%' then
 150       begin
 151         // Escaped sequence "\%"
 152         if FLeaveEscape then
 153           Talk := Talk + '\%'
 154         else
 155           Talk := Talk + '%';
 156         Inc(PStr);
 157         Continue;
 158       end else
 159       begin
 160         Dec(PStr);
 161         // might be a tag
 162         // Generate OnParser event
 163         Le := 0;
 164         Ex := '';
 165         IsErr := false;
 166         if Assigned(FOnParse) then begin
 167           FOnParse(Self, String(PStr), Le, Mt, Ex);
 168           if Le > 0 then begin
 169             if (Mt <> mtTag) and (Mt <> mtTagErr) then begin
 170               raise ESsParserError.Create(CElementTypeError);
 171               Exit;
 172             end;
 173             if Mt = mtTagErr then IsErr := true;
 174           end;
 175         end;
 176         if Le <= 0 then begin
 177           for i := 0 to FTagPattern.Count-1 do begin
 178             T := FTagPattern[i];
 179             if Length(T) = 0 then Continue;
 180             IsErr := false;
 181             if T[1] = '!' then begin
 182               IsErr := true;
 183               T[1] := '\';
 184             end else if T[1] <> '\' then
 185               raise ESsParserError.CreateFmt(CTagPatternSyntaxError, [i+1]);
 186             Le := MatchP(PStr, PChar(T));
 187             if Le > 0 then Break;
 188           end;
 189         end;
 190         if Length(Talk) > 0 then begin
 191           FMarkUpList.Add(TSsMarkUp.Create(PStr-PChar(Str)-Length(Talk), mtStr, Talk));
 192           Talk := '';
 193         end;
 194         if Le > 0 then begin
 195           // Parsed as a correct tag
 196           T := Copy(String(PStr), 1, Le);
 197           if IsErr then
 198             FMarkUpList.Add(TSsMarkUp.Create(PStr-PChar(Str), mtTagErr, T, Ex))
 199           else
 200             FMarkUpList.Add(TSsMarkUp.Create(PStr-PChar(Str), mtTag, T, Ex));
 201           Inc(PStr, Le);
 202         end else begin
 203           // Parsing failed; The character '\' and the next one character is
 204           // marked as a tag error.
 205           Inc(PStr); // Skip '\'
 206           if PStr^ in LeadBytes then
 207           begin
 208             T := '\' + Copy(String(PStr), 1, 2);
 209             FMarkUpList.Add(TSsMarkUp.Create(PStr-PChar(Str)-1, mtTagErr, T));
 210             Inc(PStr, 2);
 211           end else
 212           begin
 213             T := '\' + PStr^;
 214             FMarkUpList.Add(TSsMarkUp.Create(PStr-PChar(Str)-1, mtTagErr, T));
 215             Inc(PStr);
 216           end;
 217         end;
 218       end;
 219     end else if (PStr^ = '%') then begin
 220       Le := 0; Ex := '';
 221       if Assigned(FOnParse) then begin
 222         FOnParse(Self, String(PStr), Le, Mt, Ex);
 223         if Le > 0 then begin
 224           if Mt <> mtMeta then begin
 225             raise ESsParserError.Create(CElementTypeError);
 226             Exit;
 227           end;
 228           Dec(Le);
 229         end;
 230       end;
 231       Inc(PStr); // Skip '%'
 232       if Le <= 0 then
 233       begin
 234         for i := 0 to FMetaPattern.Count-1 do
 235         begin
 236           if Length(FMetaPattern[i]) = 0 then
 237             Continue;
 238           Le := MatchP(PStr, PChar(FMetaPattern[i]));
 239           if Le > 0 then
 240             Break;
 241         end;
 242       end;
 243       if Le > 0 then
 244       begin
 245         if Length(Talk) > 0 then
 246         begin
 247           FMarkUpList.Add(TSsMarkUp.Create(PStr-PChar(Str)-Length(Talk), mtStr, Talk));
 248           Talk := '';
 249         end;
 250         T := Copy(String(PStr), 1, Le);
 251         FMarkUpList.Add(TSsMarkUp.Create(PStr-PChar(Str)-1, mtMeta, '%' + T, Ex));
 252         Inc(PStr, Le);
 253       end else
 254       begin
 255         // in case this %??? sequence seems NOT be a meta expression
 256         if FEscapeInvalidMeta then
 257           Talk := Talk + '\%'
 258         else
 259           Talk := Talk + '%';
 260         Continue;
 261       end;
 262     end else begin
 263       if PStr^ in LeadBytes then
 264       begin
 265         Talk := Talk + Copy(String(PStr), 1, 2);
 266         Inc(PStr, 2);
 267       end else
 268       begin
 269         Talk := Talk + PStr^;
 270         Inc(PStr);
 271       end;
 272     end;
 273   end; // of while
 274   if Length(Talk) > 0 then FMarkUpList.Add(TSsMarkUp.Create(PStr-PChar(Str)-Length(Talk), mtStr, Talk));
 275 end;
 276
 277 function TSsParser.ChopFirstChar(var Str: String): String;
 278 begin
 279   Result := GetFirstChar(Str);
 280   Delete(Str, 1, Length(Result));
 281 end;
 282
 283 procedure TSsParser.ClearList;
 284 var i: integer;
 285 begin
 286   for i := FMarkUpList.Count-1 downto 0 do begin
 287     TSsMarkUp(FMarkUpList[i]).Free;
 288   end;
 289   FMarkUpList.Free;
 290   FMarkUpList := TList.Create;
 291 end;
 292
 293 constructor TSsParser.Create(AOwner: TComponent);
 294 begin
 295   inherited;
 296   FTagPattern := TStringList.Create;
 297   FMetaPattern := TStringList.Create;
 298   FMarkUpList := TList.Create;
 299   FLeaveEscape := true;
 300 end;
 301
 302 destructor TSsParser.Destroy;
 303 begin
 304   inherited;
 305   FTagPattern.Free;
 306   FMetaPattern.Free;
 307   ClearList;
 308   FMarkUpList.Free;
 309 end;
 310
 311 function TSsParser.EscapeParam(const Param: String): String;
 312 begin
 313   //StringReplace supports DBCS
 314   Result := StringReplace(Param, '\', '\\', [rfReplaceAll]);
 315   Result := StringReplace(Param, ']', '\]', [rfReplaceAll]);
 316 end;
 317
 318 function TSsParser.GetCount: integer;
 319 begin
 320   Result := FMarkUpList.Count;
 321 end;
 322
 323 function TSsParser.GetExtra(Index: integer): String;
 324 begin
 325   if (Index >= 0) and (Index <= FMarkUpList.Count-1) then
 326     Result := TSsMarkUp(FMarkUpList[Index]).Extra
 327   else
 328     Result := '';
 329 end;
 330
 331 function TSsParser.GetFirstChar(const Str: String): String;
 332 begin
 333   // Get the first character of the given string. Supports DBCS
 334   if Length(Str) <= 1 then begin
 335     Result := Str;
 336   end else begin
 337     if Str[1] in LeadBytes then begin
 338       Result := Str[1] + Str[2];
 339     end else begin
 340       Result := Str[1];
 341     end;
 342   end;
 343 end;
 344
 345 function TSsParser.GetMarkUpType(Index: integer): TSsMarkUpType;
 346 begin
 347   if (Index >= 0) and (Index <= FMarkUpList.Count-1) then
 348     Result := TSsMarkUp(FMarkUpList[Index]).MarkUpType
 349   else
 350     raise ESsParserError.Create(CMarkupIndexOutOfRange);
 351 end;
 352
 353 function TSsParser.GetParam(Tag: String;
 354   const Index: integer): String;
 355 var ParamCount: integer;
 356     First, Param: String;
 357     Escape, Inside: boolean;
 358 begin
 359   if Index <= 0 then Exit;
 360   Inside := false;
 361   ParamCount := 0;
 362   Escape := false;
 363   repeat
 364     First := ChopFirstChar(Tag);
 365     if Inside then begin
 366       if Escape then begin
 367         if First = '\' then Param := Param + '\'
 368         else if First = ']' then Param := Param + ']'
 369         else Param := Param + '\' + First;
 370         Escape := false;
 371       end else if First = '\' then
 372         Escape := true
 373       else if First = ']' then
 374         Inside := false
 375       else begin
 376         Escape := false;
 377         Param := Param + First;
 378       end;
 379     end else if First = '[' then begin
 380       Inside := true;
 381       Escape := false;
 382       Param := '';
 383       Inc(ParamCount);
 384     end;
 385   until (First = '') or ((ParamCount = Index) and not Inside);
 386   if ((ParamCount = Index) and not Inside) then
 387     Result := Param
 388   else
 389     Result := '';
 390 end;
 391
 392 function TSsParser.GetPosition(Index: integer): integer;
 393 begin
 394   if (Index >= 0) and (Index <= FMarkUpList.Count-1) then
 395     Result := TSsMarkUp(FMarkUpList[Index]).Pos
 396   else
 397     Result := 0;
 398 end;
 399
 400 function TSsParser.GetStr(Index: integer): String;
 401 begin
 402   if (Index >= 0) and (Index <= FMarkUpList.Count-1) then
 403     Result := TSsMarkUp(FMarkUpList[Index]).Str
 404   else
 405     Result := '';
 406 end;
 407
 408 function TSsParser.MarkUpAt(const Pos: integer): integer;
 409 var i, lo, hi: integer;
 410 begin
 411   if FMarkUpList.Count = 0 then
 412     Result := -1
 413   else begin
 414     lo := 0;
 415     hi := FMarkUpList.Count-2;
 416     i := (hi-lo) div 2 + lo;
 417     while (hi > lo) do
 418     begin
 419       i := (hi-lo) div 2 + lo;
 420       if (TSsMarkUp(FMarkUpList[i]).Pos >= Pos) and
 421          (TSsMarkUp(FMarkUpList[i+1]).Pos < Pos) then
 422       begin
 423          Result := i;
 424          Exit;
 425       end else if TSsMarkUp(FMarkUpList[i]).Pos > Pos then
 426         hi := i
 427       else
 428         lo := i;
 429     end;
 430     Result := i;
 431   end;
 432 end;
 433
 434 function TSsParser.Match(Str, Pattern: String): integer;
 435 begin
 436   if (Length(Str) = 0) or (Length(Pattern) = 0) then
 437     Result := 0
 438   else
 439     Result := MatchP(@Str[1], @Pattern[1]);
 440 end;
 441
 442 function TSsParser.MatchP(PStr, PPattern: PChar): integer;
 443 var Matched, F, Escape: boolean;
 444 begin
 445   Matched := true;
 446   Result := 0;
 447   while Matched and (PPattern^ <> #0) do begin
 448     if PPattern^ = '%' then
 449     begin
 450       if PStr^ = #0 then
 451       begin
 452         Matched := false;
 453         Break;
 454       end;
 455       Inc(PPattern);
 456       case PPattern^ of
 457         '%':
 458           begin
 459             if PStr^ = '%' then
 460             begin
 461               Inc(Result);
 462               Inc(PStr);
 463               Inc(PPattern);
 464             end else
 465             begin
 466               Matched := false;
 467               Break;
 468             end;
 469           end;
 470         'd':
 471           begin
 472             if PStr^ in ['0' .. '9'] then
 473             begin
 474               Inc(Result);
 475               Inc(PStr);
 476               Inc(PPattern);
 477             end else
 478               Matched := false;
 479           end;
 480         'D':
 481           begin
 482             if PStr^ in ['0' .. '9'] then
 483             begin
 484               while PStr^ in ['0' .. '9'] do
 485               begin
 486                 Inc(Result);
 487                 Inc(PStr);
 488               end;
 489               Inc(PPattern);
 490             end else
 491               Matched := false;
 492           end;
 493         'b': //String enclosed by '[' and ']'. The content may be an empty string.
 494           begin
 495             if PStr^ <> '[' then
 496             begin
 497               Matched := false;
 498             end else
 499             begin
 500               F := false;
 501               Escape := false; //After escape character
 502               Inc(PStr);   // '['
 503               Inc(Result); // '['
 504               repeat
 505                 if Escape then
 506                 begin
 507                   Escape := false;
 508                 end else
 509                 begin
 510                   if PStr^ = '\' then Escape := true;
 511                   if PStr^ = ']' then F := true;
 512                 end;
 513                 if PStr^ in LeadBytes then
 514                 begin
 515                   Inc(Result, 2);
 516                   Inc(PStr, 2);
 517                 end else
 518                 begin
 519                   Inc(Result);
 520                   Inc(PStr);
 521                 end;
 522               until (PStr^ = #0) or F;
 523               if not F then
 524                 Matched := false;
 525             end;
 526             Inc(PPattern);
 527           end;
 528         'c': // String which can be the argument content enclosed by '[' and ']'
 529           begin
 530             Inc(PPattern);
 531             if not (PStr^ = ']') then
 532             begin
 533               Escape := false;
 534               repeat
 535                 if Escape then
 536                   Escape := false
 537                 else if PStr^ = ']' then
 538                   Break
 539                 else
 540                   if PStr^ = '\' then Escape := true;
 541                 if PStr^ in LeadBytes then
 542                 begin
 543                   Inc(Result, 2);
 544                   Inc(PStr, 2);
 545                 end else
 546                 begin
 547                   Inc(Result);
 548                   Inc(PStr);
 549                 end;
 550               until (PStr^ = #0);
 551             end else
 552               Matched := false;
 553           end;
 554         'm':
 555           begin
 556             if not (PStr^ in LeadBytes) then
 557             begin
 558               Inc(PPattern);
 559               Inc(PStr);
 560               Inc(Result);
 561             end else Matched := false;
 562           end;
 563         'M':
 564           begin
 565             if (PStr^ in LeadBytes) then
 566             begin
 567               Inc(PPattern);
 568               Inc(PStr, 2);
 569               Inc(Result, 2);
 570             end else Matched := false;
 571           end;
 572         '.':
 573           if (PStr^ in LeadBytes) then
 574           begin
 575             Inc(PPattern);
 576             Inc(PStr, 2);
 577             Inc(Result, 2);
 578           end else
 579           begin
 580             Inc(PPattern);
 581             Inc(PStr);
 582             Inc(Result);
 583           end;
 584         else
 585           if PStr^ = '%' then
 586           begin
 587             Inc(PStr);
 588             Inc(Result);
 589           end else
 590           begin
 591             Matched := false;
 592           end;
 593       end // of case
 594     end else
 595     begin
 596       if PStr^ <> PPattern^ then
 597         Matched := false
 598       else
 599       begin
 600         Inc(Result);
 601         Inc(PStr);
 602         Inc(PPattern);
 603       end;
 604     end;
 605   end; //of while
 606   if not Matched then Result := 0;
 607 end;
 608
 609 procedure TSsParser.SetExtra(Index: integer; const Value: String);
 610 begin
 611   if (Index >= 0) and (Index <= FMarkUpList.Count-1) then
 612     TSsMarkUp(FMarkUpList[Index]).Extra := Value
 613   else
 614     raise ESsParserError.Create(CMarkupIndexOutOfRange);
 615 end;
 616
 617 procedure TSsParser.SetInputString(const Value: String);
 618 begin
 619   FInputString := Value;
 620   BeginParse;
 621 end;
 622
 623 procedure TSsParser.SetMetaPattern(const Value: TStrings);
 624 begin
 625   FMetaPattern.Assign(Value);
 626 end;
 627
 628 procedure TSsParser.SetOnParse(const Value: TSsParseEvent);
 629 begin
 630   FOnParse := Value;
 631 end;
 632
 633 procedure TSsParser.SetTagPattern(const Value: TStrings);
 634 begin
 635   FTagPattern.Assign(Value);
 636 end;
 637
 638 { TSsMarkUp }
 639
 640 constructor TSsMarkUp.Create(Pos: integer; MarkUpType: TSsMarkUpType; Str: String; Extra: String = '');
 641 begin
 642   FPos := Pos;
 643   FMarkUpType := MarkUpType;
 644   FStr := Str;
 645   FExtra := Extra;
 646 end;
 647
 648 procedure TSsMarkUp.SetExtra(const Value: String);
 649 begin
 650   FExtra := Value;
 651 end;
 652
 653 end.