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
 186 implementation
 187
 188 uses
 189   SysUtils, utils;
 190
 191
 192 // ////////////////////////////////////////////////////////////////////////// //
 193 function StrEqu (const a, b: AnsiString): Boolean; inline; begin result := (a = b); end;
 194
 195
 196 // ////////////////////////////////////////////////////////////////////////// //
 197 constructor TTextParser.Create ();
 198 begin
 199   mLine := 1;
 200   mCol := 1;
 201   mCurChar := #0;
 202   mNextChar := #0;
 203   mTokType := TTNone;
 204   mTokStr := '';
 205   mTokChar := #0;
 206   mTokInt := 0;
 207   mAllowSignedNumbers := true;
 208   warmup(); // change `mAllowSignedNumbers` there, if necessary
 209   skipToken();
 210 end;
 211
 212
 213 destructor TTextParser.Destroy ();
 214 begin
 215   inherited;
 216 end;
 217
 218
 219 function TTextParser.isEOF (): Boolean; inline; begin result := (mCurChar = #0); end;
 220
 221
 222 procedure TTextParser.warmup ();
 223 begin
 224   mNextChar := ' ';
 225   loadNextChar();
 226   mCurChar := mNextChar;
 227   if (mNextChar <> #0) then loadNextChar();
 228 end;
 229
 230
 231 function TTextParser.skipChar (): Boolean;
 232 begin
 233   if (mCurChar = #0) then begin result := false; exit; end;
 234   if (mCurChar = #10) then begin mCol := 1; Inc(mLine); end else Inc(mCol);
 235   mCurChar := mNextChar;
 236   if (mCurChar = #0) then begin result := false; exit; end;
 237   loadNextChar();
 238   // skip CR in CR/LF
 239   if (mCurChar = #13) then
 240   begin
 241     if (mNextChar = #10) then loadNextChar();
 242     mCurChar := #10;
 243   end;
 244   result := true;
 245 end;
 246
 247
 248 function TTextParser.skipBlanks (): Boolean;
 249 var
 250   level: Integer;
 251 begin
 252   while not isEOF do
 253   begin
 254     if (curChar = '/') then
 255     begin
 256       // single-line comment
 257       if (nextChar = '/') then
 258       begin
 259         while not isEOF and (curChar <> #10) do skipChar();
 260         skipChar(); // skip EOL
 261         continue;
 262       end;
 263       // multline comment
 264       if (nextChar = '*') then
 265       begin
 266         // skip comment start
 267         skipChar();
 268         skipChar();
 269         while not isEOF do
 270         begin
 271           if (curChar = '*') and (nextChar = '/') then
 272           begin
 273             // skip comment end
 274             skipChar();
 275             skipChar();
 276             break;
 277           end;
 278           skipChar();
 279         end;
 280         continue;
 281       end;
 282       // nesting multline comment
 283       if (nextChar = '+') then
 284       begin
 285         // skip comment start
 286         skipChar();
 287         skipChar();
 288         level := 1;
 289         while not isEOF do
 290         begin
 291           if (curChar = '+') and (nextChar = '/') then
 292           begin
 293             // skip comment end
 294             skipChar();
 295             skipChar();
 296             Dec(level);
 297             if (level = 0) then break;
 298             continue;
 299           end;
 300           if (curChar = '/') and (nextChar = '+') then
 301           begin
 302             // skip comment start
 303             skipChar();
 304             skipChar();
 305             Inc(level);
 306             continue;
 307           end;
 308           skipChar();
 309         end;
 310         continue;
 311       end;
 312     end;
 313     if (curChar > ' ') then break;
 314     skipChar(); // skip blank
 315   end;
 316   result := not isEOF;
 317 end;
 318
 319
 320 function TTextParser.skipToken (): Boolean;
 321
 322   procedure parseInt ();
 323   var
 324     neg: Boolean = false;
 325     base: Integer = -1;
 326     n: Integer;
 327   begin
 328     if mAllowSignedNumbers then
 329     begin
 330       if (curChar = '+') or (curChar = '-') then
 331       begin
 332         neg := (curChar = '-');
 333         skipChar();
 334         if (curChar < '0') or (curChar > '9') then
 335         begin
 336           mTokType := TTDelim;
 337           if (neg) then mTokChar := '-' else mTokChar := '+';
 338           exit;
 339         end;
 340       end;
 341     end;
 342     if (curChar = '0') then
 343     begin
 344       case nextChar of
 345         'b','B': base := 2;
 346         'o','O': base := 8;
 347         'd','D': base := 10;
 348         'h','H': base := 16;
 349       end;
 350       if (base > 0) then
 351       begin
 352         // skip prefix
 353         skipChar();
 354         skipChar();
 355       end;
 356     end;
 357     // default base
 358     if (base < 0) then base := 10;
 359     if (digitInBase(curChar, base) < 0) then raise Exception.Create('invalid number');
 360     mTokType := TTInt;
 361     mTokInt := 0; // just in case
 362     while not isEOF do
 363     begin
 364       n := digitInBase(curChar, base);
 365       if (n < 0) then break;
 366       n := mTokInt*10+n;
 367       if (n < 0) or (n < mTokInt) then raise Exception.Create('integer overflow');
 368       mTokInt := n;
 369       skipChar();
 370     end;
 371     // check for valid number end
 372     if not isEOF then
 373     begin
 374       if (curChar = '.') then raise Exception.Create('floating numbers aren''t supported yet');
 375       if (curChar = '_') or ((curChar >= 'A') and (curChar <= 'Z')) or ((curChar >= 'a') and (curChar <= 'z')) or (curChar >= #128) then
 376       begin
 377         raise Exception.Create('invalid number');
 378       end;
 379     end;
 380     if neg then mTokInt := -mTokInt;
 381   end;
 382
 383   procedure parseString ();
 384   var
 385     qch, ch: AnsiChar;
 386     n: Integer;
 387   begin
 388     mTokType := TTStr;
 389     mTokStr := ''; // just in case
 390     qch := curChar;
 391     skipChar(); // skip starting quote
 392     while not isEOF do
 393     begin
 394       // escape
 395       if (qch = '"') and (curChar = '\') then
 396       begin
 397         if (nextChar = #0) then raise Exception.Create('unterminated string escape');
 398         ch := nextChar;
 399         // skip backslash and escape type
 400         skipChar();
 401         skipChar();
 402         case ch of
 403           't': mTokStr += #9;
 404           'n': mTokStr += #10;
 405           'r': mTokStr += #13;
 406           'z': mTokStr += #0;
 407           'e': mTokStr += #27;
 408           'x', 'X': // hex escape
 409             begin
 410               n := digitInBase(curChar, 16);
 411               if (n < 0) then raise Exception.Create('invalid hexstr escape');
 412               skipChar();
 413               if (digitInBase(curChar, 16) > 0) then
 414               begin
 415                 n := n*16+digitInBase(curChar, 16);
 416                 skipChar();
 417               end;
 418               mTokStr += AnsiChar(n);
 419             end;
 420           else mTokStr += ch;
 421         end;
 422         continue;
 423       end;
 424       // duplicate single quote (pascal style)
 425       if (qch = '''') and (curChar = '''') and (nextChar = '''') then
 426       begin
 427         // skip both quotes
 428         skipChar();
 429         skipChar();
 430         mTokStr += '''';
 431         continue;
 432       end;
 433       if (curChar = qch) then
 434       begin
 435         skipChar(); // skip ending quote
 436         break;
 437       end;
 438       mTokStr += curChar;
 439       skipChar();
 440     end;
 441   end;
 442
 443   procedure parseId ();
 444   begin
 445     mTokType := TTId;
 446     mTokStr := ''; // just in case
 447     while (curChar = '_') or ((curChar >= '0') and (curChar <= '9')) or
 448           ((curChar >= 'A') and (curChar <= 'Z')) or
 449           ((curChar >= 'a') and (curChar <= 'z')) or
 450           (curChar >= #128) do
 451     begin
 452       mTokStr += curChar;
 453       skipChar();
 454     end;
 455   end;
 456
 457 begin
 458   mTokType := TTEOF;
 459   mTokStr := '';
 460   mTokChar := #0;
 461   mTokInt := 0;
 462
 463   if not skipBlanks() then
 464   begin
 465     result := false;
 466     mTokLine := mLine;
 467     mTokCol := mCol;
 468     exit;
 469   end;
 470
 471   mTokLine := mLine;
 472   mTokCol := mCol;
 473
 474   result := true;
 475
 476   // number?
 477   if mAllowSignedNumbers and ((curChar = '+') or (curChar = '-')) then begin parseInt(); exit; end;
 478   if (curChar >= '0') and (curChar <= '9') then begin parseInt(); exit; end;
 479
 480   // string?
 481   if (curChar = '"') or (curChar = '''') then begin parseString(); exit; end;
 482
 483   // identifier?
 484   if (curChar = '_') or ((curChar >= 'A') and (curChar <= 'Z')) or ((curChar >= 'a') and (curChar <= 'z')) or (curChar >= #128) then begin parseId(); exit; end;
 485
 486   // known delimiters?
 487   case curChar of
 488     ',': mTokType := TTComma;
 489     ':': mTokType := TTColon;
 490     ';': mTokType := TTSemi;
 491     '{': mTokType := TTBegin;
 492     '}': mTokType := TTEnd;
 493     else mTokType := TTDelim;
 494   end;
 495   mTokChar := curChar;
 496   skipChar();
 497 end;
 498
 499
 500 function TTextParser.expectId (): AnsiString;
 501 begin
 502   if (mTokType <> TTId) then raise Exception.Create('identifier expected');
 503   result := mTokStr;
 504   skipToken();
 505 end;
 506
 507
 508 procedure TTextParser.expectId (const aid: AnsiString);
 509 begin
 510   if (mTokType <> TTId) or (not StrEqu(mTokStr, aid)) then raise Exception.Create('identifier '''+aid+''' expected');
 511   skipToken();
 512 end;
 513
 514
 515 function TTextParser.eatId (const aid: AnsiString): Boolean;
 516 begin
 517   result := false;
 518   if (mTokType <> TTId) or (not StrEqu(mTokStr, aid)) then exit;
 519   result := true;
 520   skipToken();
 521 end;
 522
 523
 524 function TTextParser.expectStr (allowEmpty: Boolean=false): AnsiString;
 525 begin
 526   if (mTokType <> TTStr) then raise Exception.Create('string expected');
 527   if (not allowEmpty) and (Length(mTokStr) = 0) then raise Exception.Create('non-empty string expected');
 528   result := mTokStr;
 529   skipToken();
 530 end;
 531
 532
 533 function TTextParser.expectInt (): Integer;
 534 begin
 535   if (mTokType <> TTInt) then raise Exception.Create('string expected');
 536   result := mTokInt;
 537   skipToken();
 538 end;
 539
 540
 541 procedure TTextParser.expectTT (ttype: Integer);
 542 begin
 543   if (mTokType <> ttype) then raise Exception.Create('unexpected token');
 544   skipToken();
 545 end;
 546
 547
 548 function TTextParser.eatTT (ttype: Integer): Boolean;
 549 begin
 550   result := (mTokType = ttype);
 551   if result then skipToken();
 552 end;
 553
 554
 555 function TTextParser.expectDelim (const ch: AnsiChar): AnsiChar;
 556 begin
 557   if (mTokType <> TTDelim) then raise Exception.Create(Format('delimiter ''%s'' expected', [ch]));
 558   result := mTokChar;
 559   skipToken();
 560 end;
 561
 562
 563 function TTextParser.eatDelim (const ch: AnsiChar): Boolean;
 564 begin
 565   result := false;
 566   if (mTokType <> TTDelim) or (mTokChar <> ch) then exit;
 567   result := true;
 568   skipToken();
 569 end;
 570
 571
 572 // ////////////////////////////////////////////////////////////////////////// //
 573 constructor TFileTextParser.Create (const fname: AnsiString);
 574 begin
 575   mBuffer := nil;
 576   mFile := openDiskFileRO(fname);
 577   mStreamOwned := true;
 578   GetMem(mBuffer, BufSize);
 579   mBufPos := 0;
 580   mBufLen := mFile.Read(mBuffer^, BufSize);
 581   if (mBufLen < 0) then raise Exception.Create('TFileTextParser: read error');
 582   inherited Create();
 583 end;
 584
 585
 586 constructor TFileTextParser.Create (st: TStream; astOwned: Boolean=true);
 587 begin
 588   if (st = nil) then raise Exception.Create('cannot create parser for nil stream');
 589   mFile := st;
 590   mStreamOwned := astOwned;
 591   GetMem(mBuffer, BufSize);
 592   mBufPos := 0;
 593   mBufLen := mFile.Read(mBuffer^, BufSize);
 594   if (mBufLen < 0) then raise Exception.Create('TFileTextParser: read error');
 595   inherited Create();
 596 end;
 597
 598
 599 destructor TFileTextParser.Destroy ();
 600 begin
 601   if (mBuffer <> nil) then FreeMem(mBuffer);
 602   mBuffer := nil;
 603   mBufPos := 0;
 604   mBufLen := 0;
 605   if mStreamOwned then mFile.Free();
 606   mFile := nil;
 607   inherited;
 608 end;
 609
 610
 611 procedure TFileTextParser.loadNextChar ();
 612 begin
 613   if (mBufLen = 0) then begin mNextChar := #0; exit; end;
 614   if (mBufPos >= mBufLen) then
 615   begin
 616     mBufLen := mFile.Read(mBuffer^, BufSize);
 617     if (mBufLen < 0) then raise Exception.Create('TFileTextParser: read error');
 618     if (mBufLen = 0) then begin mNextChar := #0; exit; end;
 619     mBufPos := 0;
 620   end;
 621   assert(mBufPos < mBufLen);
 622   mNextChar := mBuffer[mBufPos];
 623   Inc(mBufPos);
 624   if (mNextChar = #0) then mNextChar := ' ';
 625 end;
 626
 627
 628 // ////////////////////////////////////////////////////////////////////////// //
 629 constructor TStrTextParser.Create (const astr: AnsiString);
 630 begin
 631   mStr := astr;
 632   mPos := 1;
 633   inherited Create();
 634 end;
 635
 636
 637 destructor TStrTextParser.Destroy ();
 638 begin
 639   mStr := '';
 640   inherited;
 641 end;
 642
 643
 644 procedure TStrTextParser.loadNextChar ();
 645 begin
 646   mNextChar := #0;
 647   if (mPos > Length(mStr)) then exit;
 648   mNextChar := mStr[mPos]; Inc(mPos);
 649   if (mNextChar = #0) then mNextChar := ' ';
 650 end;
 651
 652
 653 // ////////////////////////////////////////////////////////////////////////// //
 654 constructor TTextWriter.Create (); begin mIndent := 0; end;
 655 procedure TTextWriter.flush (); begin end;
 656 procedure TTextWriter.put (const s: AnsiString); overload; begin if (Length(s) > 0) then putBuf((@(s[1]))^, Length(s)); end;
 657 procedure TTextWriter.put (v: Byte); overload; begin put('%d', [v]); end;
 658 procedure TTextWriter.put (v: Integer); overload; begin put('%d', [v]); end;
 659 procedure TTextWriter.put (const fmt: AnsiString; args: array of const); overload; begin put(formatstrf(fmt, args)); end;
 660 procedure TTextWriter.putIndent (); var f: Integer; begin for f := 1 to mIndent do put(' '); end;
 661 procedure TTextWriter.indent (); begin Inc(mIndent, 2); end;
 662 procedure TTextWriter.unindent (); begin Dec(mIndent, 2); end;
 663
 664
 665 // ////////////////////////////////////////////////////////////////////////// //
 666 constructor TFileTextWriter.Create (const fname: AnsiString);
 667 begin
 668   mFile := createDiskFile(fname);
 669   mStreamOwned := true;
 670   mBufUsed := 0;
 671   GetMem(mBuffer, BufSize);
 672   assert(mBuffer <> nil);
 673   inherited Create();
 674 end;
 675
 676
 677 constructor TFileTextWriter.Create (ast: TStream; astOwned: Boolean=true);
 678 begin
 679   if (ast = nil) then raise Exception.Create('cannot write to nil stream');
 680   mFile := ast;
 681   mStreamOwned := astOwned;
 682   mBufUsed := 0;
 683   GetMem(mBuffer, BufSize);
 684   assert(mBuffer <> nil);
 685 end;
 686
 687
 688 destructor TFileTextWriter.Destroy ();
 689 begin
 690   flush();
 691   if (mBuffer <> nil) then FreeMem(mBuffer);
 692   mBufUsed := 0;
 693   mBuffer := nil;
 694   if (mStreamOwned) then mFile.Free();
 695   mFile := nil;
 696   inherited;
 697 end;
 698
 699
 700 procedure TFileTextWriter.flush ();
 701 begin
 702   if (mFile <> nil) and (mBufUsed > 0) then
 703   begin
 704     mFile.WriteBuffer(mBuffer^, mBufUsed);
 705   end;
 706   mBufUsed := 0;
 707 end;
 708
 709
 710 procedure TFileTextWriter.putBuf (constref buf; len: SizeUInt);
 711 var
 712   pc: PChar;
 713   left: Integer;
 714 begin
 715   if (len = 0) then exit;
 716   pc := @buf;
 717   while (len > 0) do
 718   begin
 719     left := BufSize-mBufUsed;
 720     if (left = 0) then
 721     begin
 722       flush();
 723       left := BufSize-mBufUsed;
 724       assert(left > 0);
 725     end;
 726     if (left > len) then left := Integer(len);
 727     Move(pc^, (mBuffer+mBufUsed)^, left);
 728     Inc(mBufUsed, left);
 729     pc += left;
 730     len -= left;
 731   end;
 732 end;
 733
 734
 735 end.