src/shared/xparser.pas

   1 (* Copyright (C)  DooM 2D:Forever Developers
   2  *
   3  * This program is free software: you can redistribute it and/or modify
   4  * it under the terms of the GNU General Public License as published by
   5  * the Free Software Foundation, either version 3 of the License, or
   6  * (at your option) any later version.
   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.  See the
  11  * GNU General Public License for more details.
  12  *
  13  * You should have received a copy of the GNU General Public License
  14  * along with this program.  If not, see <http://www.gnu.org/licenses/>.
  15  *)
  16 {$INCLUDE a_modes.inc}
  17 unit xparser;
  18
  19 interface
  20
  21 uses
  22   Classes;
  23
  24
  25 // ////////////////////////////////////////////////////////////////////////// //
  26 type
  27   TTextParser = class
  28   public
  29     const
  30       TTNone = -1;
  31       TTEOF = 0;
  32       TTId = 1;
  33       TTInt = 2;
  34       //TTFloat = 3; // not yet
  35       TTStr = 4; // string
  36       TTComma = 5; // ','
  37       TTColon = 6; // ':'
  38       TTSemi = 7; // ';'
  39       TTBegin = 8; // left curly
  40       TTEnd = 9; // right curly
  41       TTDelim = 10; // other delimiters
  42
  43   private
  44     mLine, mCol: Integer;
  45     mCurChar, mNextChar: AnsiChar;
  46
  47     mAllowSignedNumbers: Boolean; // internal control
  48
  49     mTokLine, mTokCol: Integer; // token start
  50     mTokType: Integer;
  51     mTokStr: AnsiString; // string or identifier
  52     mTokChar: AnsiChar; // for delimiters
  53     mTokInt: Integer;
  54
  55   protected
  56     procedure warmup (); virtual; // called in constructor to warm up the system
  57     procedure loadNextChar (); virtual; abstract; // loads next char into mNextChar; #0 means 'eof'
  58
  59   public
  60     constructor Create ();
  61     destructor Destroy (); override;
  62
  63     function isEOF (): Boolean; inline;
  64
  65     function skipChar (): Boolean; // returns `false` on eof
  66
  67     function skipBlanks (): Boolean; // ...and comments; returns `false` on eof
  68
  69     function skipToken (): Boolean; // returns `false` on eof
  70
  71     function expectId (): AnsiString;
  72     procedure expectId (const aid: AnsiString);
  73     function eatId (const aid: AnsiString): Boolean;
  74
  75     function expectStr (allowEmpty: Boolean=false): AnsiString;
  76     function expectInt (): Integer;
  77
  78     procedure expectTT (ttype: Integer);
  79     function eatTT (ttype: Integer): Boolean;
  80
  81     function expectDelim (const ch: AnsiChar): AnsiChar;
  82     function eatDelim (const ch: AnsiChar): Boolean;
  83
  84   public
  85     property col: Integer read mCol;
  86     property line: Integer read mLine;
  87
  88     property curChar: AnsiChar read mCurChar;
  89     property nextChar: AnsiChar read mNextChar;
  90
  91     // token start
  92     property tokCol: Integer read mTokCol;
  93     property tokLine: Integer read mTokLine;
  94
  95     property tokType: Integer read mTokType; // see TTXXX constants
  96     property tokStr: AnsiString read mTokStr; // string or identifier
  97     property tokChar: AnsiChar read mTokChar; // for delimiters
  98     property tokInt: Integer read mTokInt;
  99   end;
 100
 101
 102 // ////////////////////////////////////////////////////////////////////////// //
 103 type
 104   TFileTextParser = class(TTextParser)
 105   private
 106     const BufSize = 16384;
 107
 108   private
 109     mFile: TStream;
 110     mStreamOwned: Boolean;
 111     mBuffer: PChar;
 112     mBufLen: Integer;
 113     mBufPos: Integer;
 114
 115   protected
 116     procedure loadNextChar (); override; // loads next char into mNextChar; #0 means 'eof'
 117
 118   public
 119     constructor Create (const fname: AnsiString);
 120     constructor Create (st: TStream; astOwned: Boolean=true); // will take ownership on st by default
 121     destructor Destroy (); override;
 122   end;
 123
 124   TStrTextParser = class(TTextParser)
 125   private
 126     mStr: AnsiString;
 127     mPos: Integer;
 128
 129   protected
 130     procedure loadNextChar (); override; // loads next char into mNextChar; #0 means 'eof'
 131
 132   public
 133     constructor Create (const astr: AnsiString);
 134     destructor Destroy (); override;
 135   end;
 136
 137
 138 // ////////////////////////////////////////////////////////////////////////// //
 139 type
 140   TTextWriter = class
 141   protected
 142     mIndent: Integer;
 143
 144   protected
 145     procedure putBuf (constref buf; len: SizeUInt); virtual; abstract;
 146
 147   public
 148     constructor Create ();
 149
 150     procedure flush (); virtual;
 151
 152     procedure put (const s: AnsiString); overload;
 153     procedure put (v: Byte); overload;
 154     procedure put (v: Integer); overload;
 155     procedure put (const fmt: AnsiString; args: array of const); overload;
 156     procedure putIndent ();
 157     procedure indent ();
 158     procedure unindent ();
 159   end;
 160
 161
 162 // ////////////////////////////////////////////////////////////////////////// //
 163 type
 164   TFileTextWriter = class(TTextWriter)
 165   private
 166     const BufSize = 16384;
 167
 168   private
 169     mFile: TStream;
 170     mStreamOwned: Boolean;
 171     mBuffer: PAnsiChar;
 172     mBufUsed: Integer;
 173
 174   protected
 175     procedure putBuf (constref buf; len: SizeUInt); override;
 176
 177   public
 178     constructor Create (const fname: AnsiString);
 179     constructor Create (ast: TStream; astOwned: Boolean=true); // will own the stream by default
 180     destructor Destroy (); override;
 181
 182     procedure flush (); override;
 183   end;
 184
 185   TStrTextWriter = class(TTextWriter)
 186   private
 187     mStr: AnsiString;
 188
 189   protected
 190     procedure putBuf (constref buf; len: SizeUInt); override;
 191
 192   public
 193     constructor Create ();
 194     destructor Destroy (); override;
 195
 196     property str: AnsiString read mStr;
 197   end;
 198
 199
 200 implementation
 201
 202 uses
 203   SysUtils, utils;
 204
 205
 206 // ////////////////////////////////////////////////////////////////////////// //
 207 function StrEqu (const a, b: AnsiString): Boolean; inline; begin result := (a = b); end;
 208
 209
 210 // ////////////////////////////////////////////////////////////////////////// //
 211 constructor TTextParser.Create ();
 212 begin
 213   mLine := 1;
 214   mCol := 1;
 215   mCurChar := #0;
 216   mNextChar := #0;
 217   mTokType := TTNone;
 218   mTokStr := '';
 219   mTokChar := #0;
 220   mTokInt := 0;
 221   mAllowSignedNumbers := true;
 222   warmup(); // change `mAllowSignedNumbers` there, if necessary
 223   skipToken();
 224 end;
 225
 226
 227 destructor TTextParser.Destroy ();
 228 begin
 229   inherited;
 230 end;
 231
 232
 233 function TTextParser.isEOF (): Boolean; inline; begin result := (mCurChar = #0); end;
 234
 235
 236 procedure TTextParser.warmup ();
 237 begin
 238   mNextChar := ' ';
 239   loadNextChar();
 240   mCurChar := mNextChar;
 241   if (mNextChar <> #0) then loadNextChar();
 242 end;
 243
 244
 245 function TTextParser.skipChar (): Boolean;
 246 begin
 247   if (mCurChar = #0) then begin result := false; exit; end;
 248   if (mCurChar = #10) then begin mCol := 1; Inc(mLine); end else Inc(mCol);
 249   mCurChar := mNextChar;
 250   if (mCurChar = #0) then begin result := false; exit; end;
 251   loadNextChar();
 252   // skip CR in CR/LF
 253   if (mCurChar = #13) then
 254   begin
 255     if (mNextChar = #10) then loadNextChar();
 256     mCurChar := #10;
 257   end;
 258   result := true;
 259 end;
 260
 261
 262 function TTextParser.skipBlanks (): Boolean;
 263 var
 264   level: Integer;
 265 begin
 266   while not isEOF do
 267   begin
 268     if (curChar = '/') then
 269     begin
 270       // single-line comment
 271       if (nextChar = '/') then
 272       begin
 273         while not isEOF and (curChar <> #10) do skipChar();
 274         skipChar(); // skip EOL
 275         continue;
 276       end;
 277       // multline comment
 278       if (nextChar = '*') then
 279       begin
 280         // skip comment start
 281         skipChar();
 282         skipChar();
 283         while not isEOF do
 284         begin
 285           if (curChar = '*') and (nextChar = '/') then
 286           begin
 287             // skip comment end
 288             skipChar();
 289             skipChar();
 290             break;
 291           end;
 292           skipChar();
 293         end;
 294         continue;
 295       end;
 296       // nesting multline comment
 297       if (nextChar = '+') then
 298       begin
 299         // skip comment start
 300         skipChar();
 301         skipChar();
 302         level := 1;
 303         while not isEOF do
 304         begin
 305           if (curChar = '+') and (nextChar = '/') then
 306           begin
 307             // skip comment end
 308             skipChar();
 309             skipChar();
 310             Dec(level);
 311             if (level = 0) then break;
 312             continue;
 313           end;
 314           if (curChar = '/') and (nextChar = '+') then
 315           begin
 316             // skip comment start
 317             skipChar();
 318             skipChar();
 319             Inc(level);
 320             continue;
 321           end;
 322           skipChar();
 323         end;
 324         continue;
 325       end;
 326     end;
 327     if (curChar > ' ') then break;
 328     skipChar(); // skip blank
 329   end;
 330   result := not isEOF;
 331 end;
 332
 333
 334 function TTextParser.skipToken (): Boolean;
 335
 336   procedure parseInt ();
 337   var
 338     neg: Boolean = false;
 339     base: Integer = -1;
 340     n: Integer;
 341   begin
 342     if mAllowSignedNumbers then
 343     begin
 344       if (curChar = '+') or (curChar = '-') then
 345       begin
 346         neg := (curChar = '-');
 347         skipChar();
 348         if (curChar < '0') or (curChar > '9') then
 349         begin
 350           mTokType := TTDelim;
 351           if (neg) then mTokChar := '-' else mTokChar := '+';
 352           exit;
 353         end;
 354       end;
 355     end;
 356     if (curChar = '0') then
 357     begin
 358       case nextChar of
 359         'b','B': base := 2;
 360         'o','O': base := 8;
 361         'd','D': base := 10;
 362         'h','H': base := 16;
 363       end;
 364       if (base > 0) then
 365       begin
 366         // skip prefix
 367         skipChar();
 368         skipChar();
 369       end;
 370     end;
 371     // default base
 372     if (base < 0) then base := 10;
 373     if (digitInBase(curChar, base) < 0) then raise Exception.Create('invalid number');
 374     mTokType := TTInt;
 375     mTokInt := 0; // just in case
 376     while not isEOF do
 377     begin
 378       n := digitInBase(curChar, base);
 379       if (n < 0) then break;
 380       n := mTokInt*10+n;
 381       if (n < 0) or (n < mTokInt) then raise Exception.Create('integer overflow');
 382       mTokInt := n;
 383       skipChar();
 384     end;
 385     // check for valid number end
 386     if not isEOF then
 387     begin
 388       if (curChar = '.') then raise Exception.Create('floating numbers aren''t supported yet');
 389       if (curChar = '_') or ((curChar >= 'A') and (curChar <= 'Z')) or ((curChar >= 'a') and (curChar <= 'z')) or (curChar >= #128) then
 390       begin
 391         raise Exception.Create('invalid number');
 392       end;
 393     end;
 394     if neg then mTokInt := -mTokInt;
 395   end;
 396
 397   procedure parseString ();
 398   var
 399     qch, ch: AnsiChar;
 400     n: Integer;
 401   begin
 402     mTokType := TTStr;
 403     mTokStr := ''; // just in case
 404     qch := curChar;
 405     skipChar(); // skip starting quote
 406     while not isEOF do
 407     begin
 408       // escape
 409       if (qch = '"') and (curChar = '\') then
 410       begin
 411         if (nextChar = #0) then raise Exception.Create('unterminated string escape');
 412         ch := nextChar;
 413         // skip backslash and escape type
 414         skipChar();
 415         skipChar();
 416         case ch of
 417           't': mTokStr += #9;
 418           'n': mTokStr += #10;
 419           'r': mTokStr += #13;
 420           'z': mTokStr += #0;
 421           'e': mTokStr += #27;
 422           'x', 'X': // hex escape
 423             begin
 424               n := digitInBase(curChar, 16);
 425               if (n < 0) then raise Exception.Create('invalid hexstr escape');
 426               skipChar();
 427               if (digitInBase(curChar, 16) > 0) then
 428               begin
 429                 n := n*16+digitInBase(curChar, 16);
 430                 skipChar();
 431               end;
 432               mTokStr += AnsiChar(n);
 433             end;
 434           else mTokStr += ch;
 435         end;
 436         continue;
 437       end;
 438       // duplicate single quote (pascal style)
 439       if (qch = '''') and (curChar = '''') and (nextChar = '''') then
 440       begin
 441         // skip both quotes
 442         skipChar();
 443         skipChar();
 444         mTokStr += '''';
 445         continue;
 446       end;
 447       if (curChar = qch) then
 448       begin
 449         skipChar(); // skip ending quote
 450         break;
 451       end;
 452       mTokStr += curChar;
 453       skipChar();
 454     end;
 455   end;
 456
 457   procedure parseId ();
 458   begin
 459     mTokType := TTId;
 460     mTokStr := ''; // just in case
 461     while (curChar = '_') or ((curChar >= '0') and (curChar <= '9')) or
 462           ((curChar >= 'A') and (curChar <= 'Z')) or
 463           ((curChar >= 'a') and (curChar <= 'z')) or
 464           (curChar >= #128) do
 465     begin
 466       mTokStr += curChar;
 467       skipChar();
 468     end;
 469   end;
 470
 471 begin
 472   mTokType := TTEOF;
 473   mTokStr := '';
 474   mTokChar := #0;
 475   mTokInt := 0;
 476
 477   if not skipBlanks() then
 478   begin
 479     result := false;
 480     mTokLine := mLine;
 481     mTokCol := mCol;
 482     exit;
 483   end;
 484
 485   mTokLine := mLine;
 486   mTokCol := mCol;
 487
 488   result := true;
 489
 490   // number?
 491   if mAllowSignedNumbers and ((curChar = '+') or (curChar = '-')) then begin parseInt(); exit; end;
 492   if (curChar >= '0') and (curChar <= '9') then begin parseInt(); exit; end;
 493
 494   // string?
 495   if (curChar = '"') or (curChar = '''') then begin parseString(); exit; end;
 496
 497   // identifier?
 498   if (curChar = '_') or ((curChar >= 'A') and (curChar <= 'Z')) or ((curChar >= 'a') and (curChar <= 'z')) or (curChar >= #128) then begin parseId(); exit; end;
 499
 500   // known delimiters?
 501   case curChar of
 502     ',': mTokType := TTComma;
 503     ':': mTokType := TTColon;
 504     ';': mTokType := TTSemi;
 505     '{': mTokType := TTBegin;
 506     '}': mTokType := TTEnd;
 507     else mTokType := TTDelim;
 508   end;
 509   mTokChar := curChar;
 510   skipChar();
 511 end;
 512
 513
 514 function TTextParser.expectId (): AnsiString;
 515 begin
 516   if (mTokType <> TTId) then raise Exception.Create('identifier expected');
 517   result := mTokStr;
 518   skipToken();
 519 end;
 520
 521
 522 procedure TTextParser.expectId (const aid: AnsiString);
 523 begin
 524   if (mTokType <> TTId) or (not StrEqu(mTokStr, aid)) then raise Exception.Create('identifier '''+aid+''' expected');
 525   skipToken();
 526 end;
 527
 528
 529 function TTextParser.eatId (const aid: AnsiString): Boolean;
 530 begin
 531   result := false;
 532   if (mTokType <> TTId) or (not StrEqu(mTokStr, aid)) then exit;
 533   result := true;
 534   skipToken();
 535 end;
 536
 537
 538 function TTextParser.expectStr (allowEmpty: Boolean=false): AnsiString;
 539 begin
 540   if (mTokType <> TTStr) then raise Exception.Create('string expected');
 541   if (not allowEmpty) and (Length(mTokStr) = 0) then raise Exception.Create('non-empty string expected');
 542   result := mTokStr;
 543   skipToken();
 544 end;
 545
 546
 547 function TTextParser.expectInt (): Integer;
 548 begin
 549   if (mTokType <> TTInt) then raise Exception.Create('string expected');
 550   result := mTokInt;
 551   skipToken();
 552 end;
 553
 554
 555 procedure TTextParser.expectTT (ttype: Integer);
 556 begin
 557   if (mTokType <> ttype) then raise Exception.Create('unexpected token');
 558   skipToken();
 559 end;
 560
 561
 562 function TTextParser.eatTT (ttype: Integer): Boolean;
 563 begin
 564   result := (mTokType = ttype);
 565   if result then skipToken();
 566 end;
 567
 568
 569 function TTextParser.expectDelim (const ch: AnsiChar): AnsiChar;
 570 begin
 571   if (mTokType <> TTDelim) then raise Exception.Create(Format('delimiter ''%s'' expected', [ch]));
 572   result := mTokChar;
 573   skipToken();
 574 end;
 575
 576
 577 function TTextParser.eatDelim (const ch: AnsiChar): Boolean;
 578 begin
 579   result := false;
 580   if (mTokType <> TTDelim) or (mTokChar <> ch) then exit;
 581   result := true;
 582   skipToken();
 583 end;
 584
 585
 586 // ////////////////////////////////////////////////////////////////////////// //
 587 constructor TFileTextParser.Create (const fname: AnsiString);
 588 begin
 589   mBuffer := nil;
 590   mFile := openDiskFileRO(fname);
 591   mStreamOwned := true;
 592   GetMem(mBuffer, BufSize);
 593   mBufPos := 0;
 594   mBufLen := mFile.Read(mBuffer^, BufSize);
 595   if (mBufLen < 0) then raise Exception.Create('TFileTextParser: read error');
 596   inherited Create();
 597 end;
 598
 599
 600 constructor TFileTextParser.Create (st: TStream; astOwned: Boolean=true);
 601 begin
 602   if (st = nil) then raise Exception.Create('cannot create parser for nil stream');
 603   mFile := st;
 604   mStreamOwned := astOwned;
 605   GetMem(mBuffer, BufSize);
 606   mBufPos := 0;
 607   mBufLen := mFile.Read(mBuffer^, BufSize);
 608   if (mBufLen < 0) then raise Exception.Create('TFileTextParser: read error');
 609   inherited Create();
 610 end;
 611
 612
 613 destructor TFileTextParser.Destroy ();
 614 begin
 615   if (mBuffer <> nil) then FreeMem(mBuffer);
 616   mBuffer := nil;
 617   mBufPos := 0;
 618   mBufLen := 0;
 619   if mStreamOwned then mFile.Free();
 620   mFile := nil;
 621   inherited;
 622 end;
 623
 624
 625 procedure TFileTextParser.loadNextChar ();
 626 begin
 627   if (mBufLen = 0) then begin mNextChar := #0; exit; end;
 628   if (mBufPos >= mBufLen) then
 629   begin
 630     mBufLen := mFile.Read(mBuffer^, BufSize);
 631     if (mBufLen < 0) then raise Exception.Create('TFileTextParser: read error');
 632     if (mBufLen = 0) then begin mNextChar := #0; exit; end;
 633     mBufPos := 0;
 634   end;
 635   assert(mBufPos < mBufLen);
 636   mNextChar := mBuffer[mBufPos];
 637   Inc(mBufPos);
 638   if (mNextChar = #0) then mNextChar := ' ';
 639 end;
 640
 641
 642 // ////////////////////////////////////////////////////////////////////////// //
 643 constructor TStrTextParser.Create (const astr: AnsiString);
 644 begin
 645   mStr := astr;
 646   mPos := 1;
 647   inherited Create();
 648 end;
 649
 650
 651 destructor TStrTextParser.Destroy ();
 652 begin
 653   mStr := '';
 654   inherited;
 655 end;
 656
 657
 658 procedure TStrTextParser.loadNextChar ();
 659 begin
 660   mNextChar := #0;
 661   if (mPos > Length(mStr)) then exit;
 662   mNextChar := mStr[mPos]; Inc(mPos);
 663   if (mNextChar = #0) then mNextChar := ' ';
 664 end;
 665
 666
 667 // ////////////////////////////////////////////////////////////////////////// //
 668 constructor TTextWriter.Create (); begin mIndent := 0; end;
 669 procedure TTextWriter.flush (); begin end;
 670 procedure TTextWriter.put (const s: AnsiString); overload; begin if (Length(s) > 0) then putBuf((@(s[1]))^, Length(s)); end;
 671 procedure TTextWriter.put (v: Byte); overload; begin put('%d', [v]); end;
 672 procedure TTextWriter.put (v: Integer); overload; begin put('%d', [v]); end;
 673 procedure TTextWriter.put (const fmt: AnsiString; args: array of const); overload; begin put(formatstrf(fmt, args)); end;
 674 procedure TTextWriter.putIndent (); var f: Integer; begin for f := 1 to mIndent do put(' '); end;
 675 procedure TTextWriter.indent (); begin Inc(mIndent, 2); end;
 676 procedure TTextWriter.unindent (); begin Dec(mIndent, 2); end;
 677
 678
 679 // ////////////////////////////////////////////////////////////////////////// //
 680 constructor TFileTextWriter.Create (const fname: AnsiString);
 681 begin
 682   mFile := createDiskFile(fname);
 683   mStreamOwned := true;
 684   mBufUsed := 0;
 685   GetMem(mBuffer, BufSize);
 686   assert(mBuffer <> nil);
 687   inherited Create();
 688 end;
 689
 690
 691 constructor TFileTextWriter.Create (ast: TStream; astOwned: Boolean=true);
 692 begin
 693   if (ast = nil) then raise Exception.Create('cannot write to nil stream');
 694   mFile := ast;
 695   mStreamOwned := astOwned;
 696   mBufUsed := 0;
 697   GetMem(mBuffer, BufSize);
 698   assert(mBuffer <> nil);
 699 end;
 700
 701
 702 destructor TFileTextWriter.Destroy ();
 703 begin
 704   flush();
 705   if (mBuffer <> nil) then FreeMem(mBuffer);
 706   mBufUsed := 0;
 707   mBuffer := nil;
 708   if (mStreamOwned) then mFile.Free();
 709   mFile := nil;
 710   inherited;
 711 end;
 712
 713
 714 procedure TFileTextWriter.flush ();
 715 begin
 716   if (mFile <> nil) and (mBufUsed > 0) then
 717   begin
 718     mFile.WriteBuffer(mBuffer^, mBufUsed);
 719   end;
 720   mBufUsed := 0;
 721 end;
 722
 723
 724 procedure TFileTextWriter.putBuf (constref buf; len: SizeUInt);
 725 var
 726   pc: PChar;
 727   left: Integer;
 728 begin
 729   if (len = 0) then exit;
 730   pc := @buf;
 731   while (len > 0) do
 732   begin
 733     left := BufSize-mBufUsed;
 734     if (left = 0) then
 735     begin
 736       flush();
 737       left := BufSize-mBufUsed;
 738       assert(left > 0);
 739     end;
 740     if (left > len) then left := Integer(len);
 741     Move(pc^, (mBuffer+mBufUsed)^, left);
 742     Inc(mBufUsed, left);
 743     pc += left;
 744     len -= left;
 745   end;
 746 end;
 747
 748
 749 // ////////////////////////////////////////////////////////////////////////// //
 750 constructor TStrTextWriter.Create ();
 751 begin
 752   mStr := '';
 753 end;
 754
 755
 756 destructor TStrTextWriter.Destroy ();
 757 begin
 758   mStr := '';
 759   inherited;
 760 end;
 761
 762
 763 procedure TStrTextWriter.putBuf (constref buf; len: SizeUInt);
 764 var
 765   st: AnsiString = '';
 766 begin
 767   if (len > 0) then
 768   begin
 769     SetLength(st, Integer(len));
 770     Move(buf, PChar(st)^, Integer(len));
 771     mStr += st;
 772     st := '';
 773   end;
 774 end;
 775
 776
 777 end.