~ximion/listaller/master : revision 165

1

//** Unit to process RegEx commands

2

unit RegExpr;

3

{ TRegExpr class library

4

Delphi Regular Expressions

5

6

7

8

You may use this software in any kind of development,

9

including comercial, redistribute, and modify it freely,

10

under the following restrictions :

11

1. This software is provided as it is, without any kind of

12

warranty given. Use it at Your own risk.The author is not

13

responsible for any consequences of use of this software.

14

2. The origin of this software may not be mispresented, You

15

must not claim that You wrote the original software. If

16

You use this software in any kind of product, it would be

17

appreciated that there in a information box, or in the

18

documentation would be an acknowledgement like

19

20

21

http://RegExpStudio.com

22

mailto:anso@mail.ru

23

24

3. You may not have any income from distributing this source

25

(or altered version of it) to other developers. When You

26

use this product in a comercial package, the source may

27

not be charged seperatly.

28

4. Altered versions must be plainly marked as such, and must

29

not be misrepresented as being the original software.

30

5. RegExp Studio application and all the visual components as

31

well as documentation is not part of the TRegExpr library

32

and is not free for usage.

33

34

mailto:anso@mail.ru

35

http://RegExpStudio.com

36

http://anso.da.ru/}

37

interface

38

39

// ======== Determine compiler

40

{$IFDEF VER80} Sorry, TRegExpr is for 32-bits Delphi only. Delphi 1 is not supported (and whos really care today?!). {$ENDIF}

41

{$IFDEF VER90} {$DEFINE D2} {$ENDIF} // D2

42

{$IFDEF VER93} {$DEFINE D2} {$ENDIF} // CPPB 1

43

{$IFDEF VER100} {$DEFINE D3} {$DEFINE D2} {$ENDIF} // D3

44

{$IFDEF VER110} {$DEFINE D4} {$DEFINE D3} {$DEFINE D2} {$ENDIF} // CPPB 3

45

{$IFDEF VER120} {$DEFINE D4} {$DEFINE D3} {$DEFINE D2} {$ENDIF} // D4

46

{$IFDEF VER130} {$DEFINE D5} {$DEFINE D4} {$DEFINE D3} {$DEFINE D2} {$ENDIF} // D5

47

{$IFDEF VER140} {$DEFINE D6} {$DEFINE D5} {$DEFINE D4} {$DEFINE D3} {$DEFINE D2} {$ENDIF} // D6

48

{$IFDEF VER150} {$DEFINE D7} {$DEFINE D6} {$DEFINE D5} {$DEFINE D4} {$DEFINE D3} {$DEFINE D2} {$ENDIF} // D7

49

50

// ======== Define base compiler options

51

{$BOOLEVAL OFF}

52

{$EXTENDEDSYNTAX ON}

53

{$LONGSTRINGS ON}

54

{$OPTIMIZATION ON}

55

{$IFDEF D6}

56

{$WARN SYMBOL_PLATFORM OFF} // Suppress .Net warnings

57

{$ENDIF}

58

{$IFDEF D7}

59

{$WARN UNSAFE_CAST OFF} // Suppress .Net warnings

60

{$WARN UNSAFE_TYPE OFF} // Suppress .Net warnings

61

{$WARN UNSAFE_CODE OFF} // Suppress .Net warnings

62

{$ENDIF}

63

{$IFDEF FPC}

64

{$MODE DELPHI} // Delphi-compatible mode in FreePascal

65

{$ENDIF}

66

67

// ======== Define options for TRegExpr engine

68

{.$DEFINE UniCode} // Unicode support

69

{$DEFINE RegExpPCodeDump} // p-code dumping (see Dump method)

70

{$IFNDEF FPC} // the option is not supported in FreePascal

71

{$DEFINE reRealExceptionAddr} // exceptions will point to appropriate source line, not to Error procedure

72

{$ENDIF}

73

{$DEFINE ComplexBraces} // support braces in complex cases

74

{$IFNDEF UniCode} // the option applicable only for non-UniCode mode

75

{$DEFINE UseSetOfChar} // Significant optimization by using set of char

76

{$ENDIF}

77

{$IFDEF UseSetOfChar}

78

{$DEFINE UseFirstCharSet} // Fast skip between matches for r.e. that starts with determined set of chars

79

{$ENDIF}

80

81

// ======== Define Pascal-language options

82

// Define 'UseAsserts' option (do not edit this definitions).

83

// Asserts used to catch 'strange bugs' in TRegExpr implementation (when something goes

84

// completely wrong). You can swith asserts on/off with help of {$C+}/{$C-} compiler options.

85

{$IFDEF D3} {$DEFINE UseAsserts} {$ENDIF}

86

{$IFDEF FPC} {$DEFINE UseAsserts} {$ENDIF}

87

88

// Define 'use subroutine parameters default values' option (do not edit this definition).

89

{$IFDEF D4} {$DEFINE DefParam} {$ENDIF}

90

91

// Define 'OverMeth' options, to use method overloading (do not edit this definitions).

92

{$IFDEF D5} {$DEFINE OverMeth} {$ENDIF}

93

{$IFDEF FPC} {$DEFINE OverMeth} {$ENDIF}

94

95

uses

96

Classes, // TStrings in Split method

97

SysUtils; // Exception

98

99

type

100

{$IFDEF UniCode}

101

PRegExprChar = PWideChar;

102

RegExprString = WideString;

103

REChar = WideChar;

104

{$ELSE}

105

PRegExprChar = PChar;

106

RegExprString = AnsiString; //###0.952 was string

107

REChar = Char;

108

{$ENDIF}

109

TREOp = REChar; // internal p-code type //###0.933

110

PREOp = ^TREOp;

111

TRENextOff = integer; // internal Next "pointer" (offset to current p-code) //###0.933

112

PRENextOff = ^TRENextOff; // used for extracting Next "pointers" from compiled r.e. //###0.933

113

TREBracesArg = integer; // type of {m,n} arguments

114

PREBracesArg = ^TREBracesArg;

115

116

const

117

REOpSz = SizeOf (TREOp) div SizeOf (REChar); // size of p-code in RegExprString units

118

RENextOffSz = SizeOf (TRENextOff) div SizeOf (REChar); // size of Next 'pointer' -"-

119

REBracesArgSz = SizeOf (TREBracesArg) div SizeOf (REChar); // size of BRACES arguments -"-

120

121

type

122

TRegExprInvertCaseFunction = function (const Ch : REChar) : REChar

123

of object;

124

125

const

126

EscChar = '\'; // 'Escape'-char ('\' in common r.e.) used for escaping metachars (\w, \d etc).

127

RegExprModifierI : boolean = False; // default value for ModifierI

128

RegExprModifierR : boolean = True; // default value for ModifierR

129

RegExprModifierS : boolean = True; // default value for ModifierS

130

RegExprModifierG : boolean = True; // default value for ModifierG

131

RegExprModifierM : boolean = False; // default value for ModifierM

132

RegExprModifierX : boolean = False; // default value for ModifierX

133

RegExprSpaceChars : RegExprString = // default value for SpaceChars

134

' '#$9#$A#$D#$C;

135

RegExprWordChars : RegExprString = // default value for WordChars

136

'0123456789' //###0.940

137

+ 'abcdefghijklmnopqrstuvwxyz'

138

+ 'ABCDEFGHIJKLMNOPQRSTUVWXYZ_';

139

RegExprLineSeparators : RegExprString =// default value for LineSeparators

140

#$d#$a{$IFDEF UniCode}+#$b#$c#$2028#$2029#$85{$ENDIF}; //###0.947

141

RegExprLinePairedSeparator : RegExprString =// default value for LinePairedSeparator

142

#$d#$a;

143

{ if You need Unix-styled line separators (only \n), then use:

144

RegExprLineSeparators = #$a;

145

RegExprLinePairedSeparator = '';

146

}

147

148

149

const

150

NSUBEXP = 15; // max number of subexpression //###0.929

151

// Cannot be more than NSUBEXPMAX

152

// Be carefull - don't use values which overflow CLOSE opcode

153

// (in this case you'll get compiler erorr).

154

// Big NSUBEXP will cause more slow work and more stack required

155

NSUBEXPMAX = 255; // Max possible value for NSUBEXP. //###0.945

156

// Don't change it! It's defined by internal TRegExpr design.

157

158

MaxBracesArg = $7FFFFFFF - 1; // max value for {n,m} arguments //###0.933

159

160

{$IFDEF ComplexBraces}

161

LoopStackMax = 10; // max depth of loops stack //###0.925

162

{$ENDIF}

163

164

TinySetLen = 3;

165

// if range includes more then TinySetLen chars, //###0.934

166

// then use full (32 bytes) ANYOFFULL instead of ANYOF[BUT]TINYSET

167

// !!! Attension ! If you change TinySetLen, you must

168

// change code marked as "//!!!TinySet"

169

170

171

type

172

173

{$IFDEF UseSetOfChar}

174

PSetOfREChar = ^TSetOfREChar;

175

TSetOfREChar = set of REChar;

176

{$ENDIF}

177

178

TRegExpr = class;

179

180

TRegExprReplaceFunction = function (ARegExpr : TRegExpr): string

181

of object;

182

183

TRegExpr = class

184

private

185

startp : array [0 .. NSUBEXP - 1] of PRegExprChar; // founded expr starting points

186

endp : array [0 .. NSUBEXP - 1] of PRegExprChar; // founded expr end points

187

188

{$IFDEF ComplexBraces}

189

LoopStack : array [1 .. LoopStackMax] of integer; // state before entering loop

190

LoopStackIdx : integer; // 0 - out of all loops

191

{$ENDIF}

192

193

// The "internal use only" fields to pass info from compile

194

// to execute that permits the execute phase to run lots faster on

195

// simple cases.

196

regstart : REChar; // char that must begin a match; '\0' if none obvious

197

reganch : REChar; // is the match anchored (at beginning-of-line only)?

198

regmust : PRegExprChar; // string (pointer into program) that match must include, or nil

199

regmlen : integer; // length of regmust string

200

// Regstart and reganch permit very fast decisions on suitable starting points

201

// for a match, cutting down the work a lot. Regmust permits fast rejection

202

// of lines that cannot possibly match. The regmust tests are costly enough

203

// that regcomp() supplies a regmust only if the r.e. contains something

204

// potentially expensive (at present, the only such thing detected is * or +

205

// at the start of the r.e., which can involve a lot of backup). Regmlen is

206

// supplied because the test in regexec() needs it and regcomp() is computing

207

// it anyway.

208

{$IFDEF UseFirstCharSet} //###0.929

209

FirstCharSet : TSetOfREChar;

210

{$ENDIF}

211

212

// work variables for Exec's routins - save stack in recursion}

213

reginput : PRegExprChar; // String-input pointer.

214

fInputStart : PRegExprChar; // Pointer to first char of input string.

215

fInputEnd : PRegExprChar; // Pointer to char AFTER last char of input string

216

217

// work variables for compiler's routines

218

regparse : PRegExprChar; // Input-scan pointer.

219

regnpar : integer; // count.

220

regdummy : char;

221

regcode : PRegExprChar; // Code-emit pointer; @regdummy = don't.

222

regsize : integer; // Code size.

223

224

regexpbeg : PRegExprChar; // only for error handling. Contains

225

// pointer to beginning of r.e. while compiling

226

fExprIsCompiled : boolean; // true if r.e. successfully compiled

227

228

// programm is essentially a linear encoding

229

// of a nondeterministic finite-state machine (aka syntax charts or

230

// "railroad normal form" in parsing technology). Each node is an opcode

231

// plus a "next" pointer, possibly plus an operand. "Next" pointers of

232

// all nodes except BRANCH implement concatenation; a "next" pointer with

233

// a BRANCH on both ends of it is connecting two alternatives. (Here we

234

// have one of the subtle syntax dependencies: an individual BRANCH (as

235

// opposed to a collection of them) is never concatenated with anything

236

// because of operator precedence.) The operand of some types of node is

237

// a literal string; for others, it is a node leading into a sub-FSM. In

238

// particular, the operand of a BRANCH node is the first node of the branch.

239

// (NB this is *not* a tree structure: the tail of the branch connects

240

// to the thing following the set of BRANCHes.) The opcodes are:

241

programm : PRegExprChar; // Unwarranted chumminess with compiler.

242

243

fExpression : PRegExprChar; // source of compiled r.e.

244

fInputString : PRegExprChar; // input string

245

246

fLastError : integer; // see Error, LastError

247

248

fModifiers : integer; // modifiers

249

fCompModifiers : integer; // compiler's copy of modifiers

250

fProgModifiers : integer; // modifiers values from last programm compilation

251

252

fSpaceChars : RegExprString; //###0.927

253

fWordChars : RegExprString; //###0.929

254

fInvertCase : TRegExprInvertCaseFunction; //###0.927

255

256

fLineSeparators : RegExprString; //###0.941

257

fLinePairedSeparatorAssigned : boolean;

258

fLinePairedSeparatorHead,

259

fLinePairedSeparatorTail : REChar;

260

{$IFNDEF UniCode}

261

fLineSeparatorsSet : set of REChar;

262

{$ENDIF}

263

264

procedure InvalidateProgramm;

265

// Mark programm as have to be [re]compiled

266

267

function IsProgrammOk : boolean; //###0.941

268

// Check if we can use precompiled r.e. or

269

// [re]compile it if something changed

270

271

function GetExpression : RegExprString;

272

procedure SetExpression (const s : RegExprString);

273

274

function GetModifierStr : RegExprString;

275

class function ParseModifiersStr (const AModifiers : RegExprString;

276

var AModifiersInt : integer) : boolean; //###0.941 class function now

277

// Parse AModifiers string and return true and set AModifiersInt

278

// if it's in format 'ismxrg-ismxrg'.

279

procedure SetModifierStr (const AModifiers : RegExprString);

280

281

function GetModifier (AIndex : integer) : boolean;

282

procedure SetModifier (AIndex : integer; ASet : boolean);

283

284

procedure Error (AErrorID : integer); virtual; // error handler.

285

// Default handler raise exception ERegExpr with

286

// Message = ErrorMsg (AErrorID), ErrorCode = AErrorID

287

// and CompilerErrorPos = value of property CompilerErrorPos.

288

289

290

{==================== Compiler section ===================}

291

function CompileRegExpr (exp : PRegExprChar) : boolean;

292

// compile a regular expression into internal code

293

294

procedure Tail (p : PRegExprChar; val : PRegExprChar);

295

// set the next-pointer at the end of a node chain

296

297

procedure OpTail (p : PRegExprChar; val : PRegExprChar);

298

// regoptail - regtail on operand of first argument; nop if operandless

299

300

function EmitNode (op : TREOp) : PRegExprChar;

301

// regnode - emit a node, return location

302

303

procedure EmitC (b : REChar);

304

// emit (if appropriate) a byte of code

305

306

procedure InsertOperator (op : TREOp; opnd : PRegExprChar; sz : integer); //###0.90

307

// insert an operator in front of already-emitted operand

308

// Means relocating the operand.

309

310

function ParseReg (paren : integer; var flagp : integer) : PRegExprChar;

311

// regular expression, i.e. main body or parenthesized thing

312

313

function ParseBranch (var flagp : integer) : PRegExprChar;

314

// one alternative of an | operator

315

316

function ParsePiece (var flagp : integer) : PRegExprChar;

317

// something followed by possible [*+?]

318

319

function ParseAtom (var flagp : integer) : PRegExprChar;

320

// the lowest level

321

322

function GetCompilerErrorPos : integer;

323

// current pos in r.e. - for error hanling

324

325

{$IFDEF UseFirstCharSet} //###0.929

326

procedure FillFirstCharSet (prog : PRegExprChar);

327

{$ENDIF}

328

329

{===================== Mathing section ===================}

330

function regrepeat (p : PRegExprChar; AMax : integer) : integer;

331

// repeatedly match something simple, report how many

332

333

function regnext (p : PRegExprChar) : PRegExprChar;

334

// dig the "next" pointer out of a node

335

336

function MatchPrim (prog : PRegExprChar) : boolean;

337

// recursively matching routine

338

339

function ExecPrim (AOffset: integer) : boolean;

340

// Exec for stored InputString

341

342

{$IFDEF RegExpPCodeDump}

343

function DumpOp (op : REChar) : RegExprString;

344

{$ENDIF}

345

346

function GetSubExprMatchCount : integer;

347

function GetMatchPos (Idx : integer) : integer;

348

function GetMatchLen (Idx : integer) : integer;

349

function GetMatch (Idx : integer) : RegExprString;

350

351

function GetInputString : RegExprString;

352

procedure SetInputString (const AInputString : RegExprString);

353

354

{$IFNDEF UseSetOfChar}

355

function StrScanCI (s : PRegExprChar; ch : REChar) : PRegExprChar; //###0.928

356

{$ENDIF}

357

358

procedure SetLineSeparators (const AStr : RegExprString);

359

procedure SetLinePairedSeparator (const AStr : RegExprString);

360

function GetLinePairedSeparator : RegExprString;

361

362

public

363

constructor Create;

364

destructor Destroy; override;

365

366

class function VersionMajor : integer; //###0.944

367

class function VersionMinor : integer; //###0.944

368

369

property Expression : RegExprString read GetExpression write SetExpression;

370

// Regular expression.

371

// For optimization, TRegExpr will automatically compiles it into 'P-code'

372

// (You can see it with help of Dump method) and stores in internal

373

// structures. Real [re]compilation occures only when it really needed -

374

// while calling Exec[Next], Substitute, Dump, etc

375

// and only if Expression or other P-code affected properties was changed

376

// after last [re]compilation.

377

// If any errors while [re]compilation occures, Error method is called

378

// (by default Error raises exception - see below)

379

380

property ModifierStr : RegExprString read GetModifierStr write SetModifierStr;

381

// Set/get default values of r.e.syntax modifiers. Modifiers in

382

// r.e. (?ismx-ismx) will replace this default values.

383

// If you try to set unsupported modifier, Error will be called

384

// (by defaul Error raises exception ERegExpr).

385

386

property ModifierI : boolean index 1 read GetModifier write SetModifier;

387

// Modifier /i - caseinsensitive, initialized from RegExprModifierI

388

389

property ModifierR : boolean index 2 read GetModifier write SetModifier;

390

// Modifier /r - use r.e.syntax extended for russian,

391

// (was property ExtSyntaxEnabled in previous versions)

392

// If true, then �-� additional include russian letter '�',

393

// �-� additional include '�', and �-� include all russian symbols.

394

// You have to turn it off if it may interfere with you national alphabet.

395

// , initialized from RegExprModifierR

396

397

property ModifierS : boolean index 3 read GetModifier write SetModifier;

398

// Modifier /s - '.' works as any char (else as [^\n]),

399

// , initialized from RegExprModifierS

400

401

property ModifierG : boolean index 4 read GetModifier write SetModifier;

402

// Switching off modifier /g switchs all operators in

403

// non-greedy style, so if ModifierG = False, then

404

// all '*' works as '*?', all '+' as '+?' and so on.

405

// , initialized from RegExprModifierG

406

407

property ModifierM : boolean index 5 read GetModifier write SetModifier;

408

// Treat string as multiple lines. That is, change `^' and `$' from

409

// matching at only the very start or end of the string to the start

410

// or end of any line anywhere within the string.

411

// , initialized from RegExprModifierM

412

413

property ModifierX : boolean index 6 read GetModifier write SetModifier;

414

// Modifier /x - eXtended syntax, allow r.e. text formatting,

415

// see description in the help. Initialized from RegExprModifierX

416

417

function Exec (const AInputString : RegExprString) : boolean; {$IFDEF OverMeth} overload;

418

{$IFNDEF FPC} // I do not know why FreePascal cannot overload methods with empty param list

419

function Exec : boolean; overload; //###0.949

420

{$ENDIF}

421

function Exec (AOffset: integer) : boolean; overload; //###0.949

422

{$ENDIF}

423

// match a programm against a string AInputString

424

// !!! Exec store AInputString into InputString property

425

// For Delphi 5 and higher available overloaded versions - first without

426

// parameter (uses already assigned to InputString property value)

427

// and second that has integer parameter and is same as ExecPos

428

429

function ExecNext : boolean;

430

// find next match:

431

// ExecNext;

432

// works same as

433

// if MatchLen [0] = 0 then ExecPos (MatchPos [0] + 1)

434

// else ExecPos (MatchPos [0] + MatchLen [0]);

435

// but it's more simpler !

436

// Raises exception if used without preceeding SUCCESSFUL call to

437

// Exec* (Exec, ExecPos, ExecNext). So You always must use something like

438

// if Exec (InputString) then repeat { proceed results} until not ExecNext;

439

440

function ExecPos (AOffset: integer {$IFDEF DefParam}= 1{$ENDIF}) : boolean;

441

// find match for InputString starting from AOffset position

442

// (AOffset=1 - first char of InputString)

443

444

property InputString : RegExprString read GetInputString write SetInputString;

445

// returns current input string (from last Exec call or last assign

446

// to this property).

447

// Any assignment to this property clear Match* properties !

448

449

function Substitute (const ATemplate : RegExprString) : RegExprString;

450

// Returns ATemplate with '$&' or '$0' replaced by whole r.e.

451

// occurence and '$n' replaced by occurence of subexpression #n.

452

// Since v.0.929 '$' used instead of '\' (for future extensions

453

// and for more Perl-compatibility) and accept more then one digit.

454

// If you want place into template raw '$' or '\', use prefix '\'

455

// Example: '1\$ is $2\\rub\\' -> '1$ is <Match[2]>\rub\'

456

// If you want to place raw digit after '$n' you must delimit

457

// n with curly braces '{}'.

458

// Example: 'a$12bc' -> 'a<Match[12]>bc'

459

// 'a${1}2bc' -> 'a<Match[1]>2bc'.

460

461

procedure Split (AInputStr : RegExprString; APieces : TStrings);

462

// Split AInputStr into APieces by r.e. occurencies

463

// Internally calls Exec[Next]

464

465

function Replace (AInputStr : RegExprString;

466

const AReplaceStr : RegExprString;

467

AUseSubstitution : boolean{$IFDEF DefParam}= False{$ENDIF}) //###0.946

468

: RegExprString; {$IFDEF OverMeth} overload;

469

function Replace (AInputStr : RegExprString;

470

AReplaceFunc : TRegExprReplaceFunction)

471

: RegExprString; overload;

472

{$ENDIF}

473

function ReplaceEx (AInputStr : RegExprString;

474

AReplaceFunc : TRegExprReplaceFunction)

475

: RegExprString;

476

// Returns AInputStr with r.e. occurencies replaced by AReplaceStr

477

// If AUseSubstitution is true, then AReplaceStr will be used

478

// as template for Substitution methods.

479

// For example:

480

// Expression := '({-i}block|var)\s*$\s*([^ ]*)\s*$\s*';

481

// Replace ('BLOCK( test1)', 'def "$1" value "$2"', True);

482

// will return: def 'BLOCK' value 'test1'

483

// Replace ('BLOCK( test1)', 'def "$1" value "$2"')

484

// will return: def "$1" value "$2"

485

// Internally calls Exec[Next]

486

// Overloaded version and ReplaceEx operate with call-back function,

487

// so You can implement really complex functionality.

488

489

property SubExprMatchCount : integer read GetSubExprMatchCount;

490

// Number of subexpressions has been found in last Exec* call.

491

// If there are no subexpr. but whole expr was found (Exec* returned True),

492

// then SubExprMatchCount=0, if no subexpressions nor whole

493

// r.e. found (Exec* returned false) then SubExprMatchCount=-1.

494

// Note, that some subexpr. may be not found and for such

495

// subexpr. MathPos=MatchLen=-1 and Match=''.

496

// For example: Expression := '(1)?2(3)?';

497

// Exec ('123'): SubExprMatchCount=2, Match[0]='123', [1]='1', [2]='3'

498

// Exec ('12'): SubExprMatchCount=1, Match[0]='12', [1]='1'

499

// Exec ('23'): SubExprMatchCount=2, Match[0]='23', [1]='', [2]='3'

500

// Exec ('2'): SubExprMatchCount=0, Match[0]='2'

501

// Exec ('7') - return False: SubExprMatchCount=-1

502

503

property MatchPos [Idx : integer] : integer read GetMatchPos;

504

// pos of entrance subexpr. #Idx into tested in last Exec*

505

// string. First subexpr. have Idx=1, last - MatchCount,

506

// whole r.e. have Idx=0.

507

// Returns -1 if in r.e. no such subexpr. or this subexpr.

508

// not found in input string.

509

510

property MatchLen [Idx : integer] : integer read GetMatchLen;

511

// len of entrance subexpr. #Idx r.e. into tested in last Exec*

512

// string. First subexpr. have Idx=1, last - MatchCount,

513

// whole r.e. have Idx=0.

514

// Returns -1 if in r.e. no such subexpr. or this subexpr.

515

// not found in input string.

516

// Remember - MatchLen may be 0 (if r.e. match empty string) !

517

518

property Match [Idx : integer] : RegExprString read GetMatch;

519

// == copy (InputString, MatchPos [Idx], MatchLen [Idx])

520

// Returns '' if in r.e. no such subexpr. or this subexpr.

521

// not found in input string.

522

523

function LastError : integer;

524

// Returns ID of last error, 0 if no errors (unusable if

525

// Error method raises exception) and clear internal status

526

// into 0 (no errors).

527

528

function ErrorMsg (AErrorID : integer) : RegExprString; virtual;

529

// Returns Error message for error with ID = AErrorID.

530

531

property CompilerErrorPos : integer read GetCompilerErrorPos;

532

// Returns pos in r.e. there compiler stopped.

533

// Usefull for error diagnostics

534

535

property SpaceChars : RegExprString read fSpaceChars write fSpaceChars; //###0.927

536

// Contains chars, treated as /s (initially filled with RegExprSpaceChars

537

// global constant)

538

539

property WordChars : RegExprString read fWordChars write fWordChars; //###0.929

540

// Contains chars, treated as /w (initially filled with RegExprWordChars

541

// global constant)

542

543

property LineSeparators : RegExprString read fLineSeparators write SetLineSeparators; //###0.941

544

// line separators (like \n in Unix)

545

546

property LinePairedSeparator : RegExprString read GetLinePairedSeparator write SetLinePairedSeparator; //###0.941

547

// paired line separator (like \r\n in DOS and Windows).

548

// must contain exactly two chars or no chars at all

549

550

class function InvertCaseFunction (const Ch : REChar) : REChar;

551

// Converts Ch into upper case if it in lower case or in lower

552

// if it in upper (uses current system local setings)

553

554

property InvertCase : TRegExprInvertCaseFunction read fInvertCase write fInvertCase; //##0.935

555

// Set this property if you want to override case-insensitive functionality.

556

// Create set it to RegExprInvertCaseFunction (InvertCaseFunction by default)

557

558

procedure Compile; //###0.941

559

// [Re]compile r.e. Usefull for example for GUI r.e. editors (to check

560

// all properties validity).

561

562

{$IFDEF RegExpPCodeDump}

563

function Dump : RegExprString;

564

// dump a compiled regexp in vaguely comprehensible form

565

{$ENDIF}

566

end;

567

568

ERegExpr = class (Exception)

569

public

570

ErrorCode : integer;

571

CompilerErrorPos : integer;

572

end;

573

574

const

575

RegExprInvertCaseFunction : TRegExprInvertCaseFunction = {$IFDEF FPC} nil {$ELSE} TRegExpr.InvertCaseFunction{$ENDIF};

576

// defaul for InvertCase property

577

578

function ExecRegExpr (const ARegExpr, AInputStr : RegExprString) : boolean;

579

// true if string AInputString match regular expression ARegExpr

580

// ! will raise exeption if syntax errors in ARegExpr

581

582

procedure SplitRegExpr (const ARegExpr, AInputStr : RegExprString; APieces : TStrings);

583

// Split AInputStr into APieces by r.e. ARegExpr occurencies

584

585

function ReplaceRegExpr (const ARegExpr, AInputStr, AReplaceStr : RegExprString;

586

AUseSubstitution : boolean{$IFDEF DefParam}= False{$ENDIF}) : RegExprString; //###0.947

587

// Returns AInputStr with r.e. occurencies replaced by AReplaceStr

588

// If AUseSubstitution is true, then AReplaceStr will be used

589

// as template for Substitution methods.

590

// For example:

591

// ReplaceRegExpr ('({-i}block|var)\s*$\s*([^ ]*)\s*$\s*',

592

// 'BLOCK( test1)', 'def "$1" value "$2"', True)

593

// will return: def 'BLOCK' value 'test1'

594

// ReplaceRegExpr ('({-i}block|var)\s*$\s*([^ ]*)\s*$\s*',

595

// 'BLOCK( test1)', 'def "$1" value "$2"')

596

// will return: def "$1" value "$2"

597

598

function QuoteRegExprMetaChars (const AStr : RegExprString) : RegExprString;

599

// Replace all metachars with its safe representation,

600

// for example 'abc$cd.(' converts into 'abc\$cd\.\('

601

// This function usefull for r.e. autogeneration from

602

// user input

603

604

function RegExprSubExpressions (const ARegExpr : string;

605

ASubExprs : TStrings; AExtendedSyntax : boolean{$IFDEF DefParam}= False{$ENDIF}) : integer;

606

// Makes list of subexpressions found in ARegExpr r.e.

607

// In ASubExps every item represent subexpression,

608

// from first to last, in format:

609

// String - subexpression text (without '()')

610

// low word of Object - starting position in ARegExpr, including '('

611

// if exists! (first position is 1)

612

// high word of Object - length, including starting '(' and ending ')'

613

// if exist!

614

// AExtendedSyntax - must be True if modifier /m will be On while

615

// using the r.e.

616

// Usefull for GUI editors of r.e. etc (You can find example of using

617

// in TestRExp.dpr project)

618

// Returns

619

// 0 Success. No unbalanced brackets was found;

620

// -1 There are not enough closing brackets ')';

621

// -(n+1) At position n was found opening '[' without //###0.942

622

// corresponding closing ']';

623

// n At position n was found closing bracket ')' without

624

// corresponding opening '('.

625

// If Result <> 0, then ASubExpr can contain empty items or illegal ones

626

627

628

implementation

629

630

const

631

TRegExprVersionMajor : integer = 0;

632

TRegExprVersionMinor : integer = 952;

633

// TRegExpr.VersionMajor/Minor return values of this constants

634

635

MaskModI = 1; // modifier /i bit in fModifiers

636

MaskModR = 2; // -"- /r

637

MaskModS = 4; // -"- /s

638

MaskModG = 8; // -"- /g

639

MaskModM = 16; // -"- /m

640

MaskModX = 32; // -"- /x

641

642

{$IFDEF UniCode}

643

XIgnoredChars = ' '#9#$d#$a;

644

{$ELSE}

645

XIgnoredChars = [' ', #9, #$d, #$a];

646

{$ENDIF}

647

648

{=============================================================}

649

{=================== WideString functions ====================}

650

{=============================================================}

651

652

{$IFDEF UniCode}

653

654

function StrPCopy (Dest: PRegExprChar; const Source: RegExprString): PRegExprChar;

655

var

656

i, Len : Integer;

657

begin

658

Len := length (Source); //###0.932

659

for i := 1 to Len do

660

Dest [i - 1] := Source [i];

661

Dest [Len] := #0;

662

Result := Dest;

663

end; { of function StrPCopy

664

--------------------------------------------------------------}

665

666

function StrLCopy (Dest, Source: PRegExprChar; MaxLen: Cardinal): PRegExprChar;

667

var i: Integer;

668

begin

669

for i := 0 to MaxLen - 1 do

670

Dest [i] := Source [i];

671

Result := Dest;

672

end; { of function StrLCopy

673

--------------------------------------------------------------}

674

675

function StrLen (Str: PRegExprChar): Cardinal;

676

begin

677

Result:=0;

678

while Str [result] <> #0

679

do Inc (Result);

680

end; { of function StrLen

681

--------------------------------------------------------------}

682

683

function StrPos (Str1, Str2: PRegExprChar): PRegExprChar;

684

var n: Integer;

685

begin

686

Result := nil;

687

n := Pos (RegExprString (Str2), RegExprString (Str1));

688

if n = 0

689

then EXIT;

690

Result := Str1 + n - 1;

691

end; { of function StrPos

692

--------------------------------------------------------------}

693

694

function StrLComp (Str1, Str2: PRegExprChar; MaxLen: Cardinal): Integer;

695

var S1, S2: RegExprString;

696

begin

697

S1 := Str1;

698

S2 := Str2;

699

if Copy (S1, 1, MaxLen) > Copy (S2, 1, MaxLen)

700

then Result := 1

701

else

702

if Copy (S1, 1, MaxLen) < Copy (S2, 1, MaxLen)

703

then Result := -1

704

else Result := 0;

705

end; { function StrLComp

706

--------------------------------------------------------------}

707

708

function StrScan (Str: PRegExprChar; Chr: WideChar): PRegExprChar;

709

begin

710

Result := nil;

711

while (Str^ <> #0) and (Str^ <> Chr)

712

do Inc (Str);

713

if (Str^ <> #0)

714

then Result := Str;

715

end; { of function StrScan

716

--------------------------------------------------------------}

717

718

{$ENDIF}

719

720

721

{=============================================================}

722

{===================== Global functions ======================}

723

{=============================================================}

724

725

function ExecRegExpr (const ARegExpr, AInputStr : RegExprString) : boolean;

726

var r : TRegExpr;

727

begin

728

r := TRegExpr.Create;

729

try

730

r.Expression := ARegExpr;

731

Result := r.Exec (AInputStr);

732

finally r.Free;

733

end;

734

end; { of function ExecRegExpr

735

--------------------------------------------------------------}

736

737

procedure SplitRegExpr (const ARegExpr, AInputStr : RegExprString; APieces : TStrings);

738

var r : TRegExpr;

739

begin

740

APieces.Clear;

741

r := TRegExpr.Create;

742

try

743

r.Expression := ARegExpr;

744

r.Split (AInputStr, APieces);

745

finally r.Free;

746

end;

747

end; { of procedure SplitRegExpr

748

--------------------------------------------------------------}

749

750

function ReplaceRegExpr (const ARegExpr, AInputStr, AReplaceStr : RegExprString;

751

AUseSubstitution : boolean{$IFDEF DefParam}= False{$ENDIF}) : RegExprString;

752

begin

753

with TRegExpr.Create do try

754

Expression := ARegExpr;

755

Result := Replace (AInputStr, AReplaceStr, AUseSubstitution);

756

finally Free;

757

end;

758

end; { of function ReplaceRegExpr

759

--------------------------------------------------------------}

760

761

function QuoteRegExprMetaChars (const AStr : RegExprString) : RegExprString;

762

const

763

RegExprMetaSet : RegExprString = '^$.[()|?+*'+EscChar+'{'

764

+ ']}'; // - this last are additional to META.

765

// Very similar to META array, but slighly changed.

766

// !Any changes in META array must be synchronized with this set.

767

var

768

i, i0, Len : integer;

769

begin

770

Result := '';

771

Len := length (AStr);

772

i := 1;

773

i0 := i;

774

while i <= Len do begin

775

if Pos (AStr [i], RegExprMetaSet) > 0 then begin

776

Result := Result + System.Copy (AStr, i0, i - i0)

777

+ EscChar + AStr [i];

778

i0 := i + 1;

779

end;

780

inc (i);

781

end;

782

Result := Result + System.Copy (AStr, i0, MaxInt); // Tail

783

end; { of function QuoteRegExprMetaChars

784

--------------------------------------------------------------}

785

786

function RegExprSubExpressions (const ARegExpr : string;

787

ASubExprs : TStrings; AExtendedSyntax : boolean{$IFDEF DefParam}= False{$ENDIF}) : integer;

788

type

789

TStackItemRec = record //###0.945

790

SubExprIdx : integer;

791

StartPos : integer;

792

end;

793

TStackArray = packed array [0 .. NSUBEXPMAX - 1] of TStackItemRec;

794

var

795

Len, SubExprLen : integer;

796

i, i0 : integer;

797

Modif : integer;

798

Stack : ^TStackArray; //###0.945

799

StackIdx, StackSz : integer;

800

begin

801

Result := 0; // no unbalanced brackets found at this very moment

802

803

ASubExprs.Clear; // I don't think that adding to non empty list

804

// can be usefull, so I simplified algorithm to work only with empty list

805

806

Len := length (ARegExpr); // some optimization tricks

807

808

// first we have to calculate number of subexpression to reserve

809

// space in Stack array (may be we'll reserve more then need, but

810

// it's faster then memory reallocation during parsing)

811

StackSz := 1; // add 1 for entire r.e.

812

for i := 1 to Len do

813

if ARegExpr [i] = '('

814

then inc (StackSz);

815

// SetLength (Stack, StackSz); //###0.945

816

GetMem (Stack, SizeOf (TStackItemRec) * StackSz);

817

try

818

819

StackIdx := 0;

820

i := 1;

821

while (i <= Len) do begin

822

case ARegExpr [i] of

823

'(': begin

824

if (i < Len) and (ARegExpr [i + 1] = '?') then begin

825

// this is not subexpression, but comment or other

826

// Perl extension. We must check is it (?ismxrg-ismxrg)

827

// and change AExtendedSyntax if /x is changed.

828

inc (i, 2); // skip '(?'

829

i0 := i;

830

while (i <= Len) and (ARegExpr [i] <> ')')

831

do inc (i);

832

if i > Len

833

then Result := -1 // unbalansed '('

834

else

835

if TRegExpr.ParseModifiersStr (System.Copy (ARegExpr, i, i - i0), Modif)

836

then AExtendedSyntax := (Modif and MaskModX) <> 0;

837

end

838

else begin // subexpression starts

839

ASubExprs.Add (''); // just reserve space

840

with Stack [StackIdx] do begin

841

SubExprIdx := ASubExprs.Count - 1;

842

StartPos := i;

843

end;

844

inc (StackIdx);

845

end;

846

end;

847

')': begin

848

if StackIdx = 0

849

then Result := i // unbalanced ')'

850

else begin

851

dec (StackIdx);

852

with Stack [StackIdx] do begin

853

SubExprLen := i - StartPos + 1;

854

ASubExprs.Objects [SubExprIdx] :=

855

TObject (StartPos or (SubExprLen ShL 16));

856

ASubExprs [SubExprIdx] := System.Copy (

857

ARegExpr, StartPos + 1, SubExprLen - 2); // add without brackets

858

end;

859

end;

860

end;

861

EscChar: inc (i); // skip quoted symbol

862

'[': begin

863

// we have to skip character ranges at once, because they can

864

// contain '#', and '#' in it must NOT be recognized as eXtended

865

// comment beginning!

866

i0 := i;

867

inc (i);

868

if ARegExpr [i] = ']' // cannot be 'emty' ranges - this interpretes

869

then inc (i); // as ']' by itself

870

while (i <= Len) and (ARegExpr [i] <> ']') do

871

if ARegExpr [i] = EscChar //###0.942

872

then inc (i, 2) // skip 'escaped' char to prevent stopping at '\]'

873

else inc (i);

874

if (i > Len) or (ARegExpr [i] <> ']') //###0.942

875

then Result := - (i0 + 1); // unbalansed '[' //###0.942

876

end;

877

'#': if AExtendedSyntax then begin

878

// skip eXtended comments

879

while (i <= Len) and (ARegExpr [i] <> #$d) and (ARegExpr [i] <> #$a)

880

// do not use [#$d, #$a] due to UniCode compatibility

881

do inc (i);

882

while (i + 1 <= Len) and ((ARegExpr [i + 1] = #$d) or (ARegExpr [i + 1] = #$a))

883

do inc (i); // attempt to work with different kinds of line separators

884

// now we are at the line separator that must be skipped.

885

end;

886

// here is no 'else' clause - we simply skip ordinary chars

887

end; // of case

888

inc (i); // skip scanned char

889

// ! can move after Len due to skipping quoted symbol

890

end;

891

892

// check brackets balance

893

if StackIdx <> 0

894

then Result := -1; // unbalansed '('

895

896

// check if entire r.e. added

897

if (ASubExprs.Count = 0)

898

or ((integer (ASubExprs.Objects [0]) and $FFFF) <> 1)

899

or (((integer (ASubExprs.Objects [0]) ShR 16) and $FFFF) <> Len)

900

// whole r.e. wasn't added because it isn't bracketed

901

// well, we add it now:

902

then ASubExprs.InsertObject (0, ARegExpr, TObject ((Len ShL 16) or 1));

903

904

finally FreeMem (Stack);

905

end;

906

end; { of function RegExprSubExpressions

907

--------------------------------------------------------------}

908

909

910

911

const

912

MAGIC = TREOp (216);// programm signature

913

914

// name opcode opnd? meaning

915

EEND = TREOp (0); // - End of program

916

BOL = TREOp (1); // - Match "" at beginning of line

917

EOL = TREOp (2); // - Match "" at end of line

918

ANY = TREOp (3); // - Match any one character

919

ANYOF = TREOp (4); // Str Match any character in string Str

920

ANYBUT = TREOp (5); // Str Match any char. not in string Str

921

BRANCH = TREOp (6); // Node Match this alternative, or the next

922

BACK = TREOp (7); // - Jump backward (Next < 0)

923

EXACTLY = TREOp (8); // Str Match string Str

924

NOTHING = TREOp (9); // - Match empty string

925

STAR = TREOp (10); // Node Match this (simple) thing 0 or more times

926

PLUS = TREOp (11); // Node Match this (simple) thing 1 or more times

927

ANYDIGIT = TREOp (12); // - Match any digit (equiv [0-9])

928

NOTDIGIT = TREOp (13); // - Match not digit (equiv [0-9])

929

ANYLETTER = TREOp (14); // - Match any letter from property WordChars

930

NOTLETTER = TREOp (15); // - Match not letter from property WordChars

931

ANYSPACE = TREOp (16); // - Match any space char (see property SpaceChars)

932

NOTSPACE = TREOp (17); // - Match not space char (see property SpaceChars)

933

BRACES = TREOp (18); // Node,Min,Max Match this (simple) thing from Min to Max times.

934

// Min and Max are TREBracesArg

935

COMMENT = TREOp (19); // - Comment ;)

936

EXACTLYCI = TREOp (20); // Str Match string Str case insensitive

937

ANYOFCI = TREOp (21); // Str Match any character in string Str, case insensitive

938

ANYBUTCI = TREOp (22); // Str Match any char. not in string Str, case insensitive

939

LOOPENTRY = TREOp (23); // Node Start of loop (Node - LOOP for this loop)

940

LOOP = TREOp (24); // Node,Min,Max,LoopEntryJmp - back jump for LOOPENTRY.

941

// Min and Max are TREBracesArg

942

// Node - next node in sequence,

943

// LoopEntryJmp - associated LOOPENTRY node addr

944

ANYOFTINYSET= TREOp (25); // Chrs Match any one char from Chrs (exactly TinySetLen chars)

945

ANYBUTTINYSET=TREOp (26); // Chrs Match any one char not in Chrs (exactly TinySetLen chars)

946

ANYOFFULLSET= TREOp (27); // Set Match any one char from set of char

947

// - very fast (one CPU instruction !) but takes 32 bytes of p-code

948

BSUBEXP = TREOp (28); // Idx Match previously matched subexpression #Idx (stored as REChar) //###0.936

949

BSUBEXPCI = TREOp (29); // Idx -"- in case-insensitive mode

950

951

// Non-Greedy Style Ops //###0.940

952

STARNG = TREOp (30); // Same as START but in non-greedy mode

953

PLUSNG = TREOp (31); // Same as PLUS but in non-greedy mode

954

BRACESNG = TREOp (32); // Same as BRACES but in non-greedy mode

955

LOOPNG = TREOp (33); // Same as LOOP but in non-greedy mode

956

957

// Multiline mode \m

958

BOLML = TREOp (34); // - Match "" at beginning of line

959

EOLML = TREOp (35); // - Match "" at end of line

960

ANYML = TREOp (36); // - Match any one character

961

962

// Word boundary

963

BOUND = TREOp (37); // Match "" between words //###0.943

964

NOTBOUND = TREOp (38); // Match "" not between words //###0.943

965

966

// !!! Change OPEN value if you add new opcodes !!!

967

968

OPEN = TREOp (39); // - Mark this point in input as start of \n

969

// OPEN + 1 is \1, etc.

970

CLOSE = TREOp (ord (OPEN) + NSUBEXP);

971

// - Analogous to OPEN.

972

973

// !!! Don't add new OpCodes after CLOSE !!!

974

975

// We work with p-code thru pointers, compatible with PRegExprChar.

976

// Note: all code components (TRENextOff, TREOp, TREBracesArg, etc)

977

// must have lengths that can be divided by SizeOf (REChar) !

978

// A node is TREOp of opcode followed Next "pointer" of TRENextOff type.

979

// The Next is a offset from the opcode of the node containing it.

980

// An operand, if any, simply follows the node. (Note that much of

981

// the code generation knows about this implicit relationship!)

982

// Using TRENextOff=integer speed up p-code processing.

983

984

// Opcodes description:

985

//

986

// BRANCH The set of branches constituting a single choice are hooked

987

// together with their "next" pointers, since precedence prevents

988

// anything being concatenated to any individual branch. The

989

// "next" pointer of the last BRANCH in a choice points to the

990

// thing following the whole choice. This is also where the

991

// final "next" pointer of each individual branch points; each

992

// branch starts with the operand node of a BRANCH node.

993

// BACK Normal "next" pointers all implicitly point forward; BACK

994

// exists to make loop structures possible.

995

// STAR,PLUS,BRACES '?', and complex '*' and '+', are implemented as

996

// circular BRANCH structures using BACK. Complex '{min,max}'

997

// - as pair LOOPENTRY-LOOP (see below). Simple cases (one

998

// character per match) are implemented with STAR, PLUS and

999

// BRACES for speed and to minimize recursive plunges.

1000

// LOOPENTRY,LOOP {min,max} are implemented as special pair

1001

// LOOPENTRY-LOOP. Each LOOPENTRY initialize loopstack for

1002

// current level.

1003

// OPEN,CLOSE are numbered at compile time.

1004

1005

1006

{=============================================================}

1007

{================== Error handling section ===================}

1008

{=============================================================}

1009

1010

const

1011

reeOk = 0;

1012

reeCompNullArgument = 100;

1013

reeCompRegexpTooBig = 101;

1014

reeCompParseRegTooManyBrackets = 102;

1015

reeCompParseRegUnmatchedBrackets = 103;

1016

reeCompParseRegUnmatchedBrackets2 = 104;

1017

reeCompParseRegJunkOnEnd = 105;

1018

reePlusStarOperandCouldBeEmpty = 106;

1019

reeNestedSQP = 107;

1020

reeBadHexDigit = 108;

1021

reeInvalidRange = 109;

1022

reeParseAtomTrailingBackSlash = 110;

1023

reeNoHexCodeAfterBSlashX = 111;

1024

reeHexCodeAfterBSlashXTooBig = 112;

1025

reeUnmatchedSqBrackets = 113;

1026

reeInternalUrp = 114;

1027

reeQPSBFollowsNothing = 115;

1028

reeTrailingBackSlash = 116;

1029

reeRarseAtomInternalDisaster = 119;

1030

reeBRACESArgTooBig = 122;

1031

reeBracesMinParamGreaterMax = 124;

1032

reeUnclosedComment = 125;

1033

reeComplexBracesNotImplemented = 126;

1034

reeUrecognizedModifier = 127;

1035

reeBadLinePairedSeparator = 128;

1036

reeRegRepeatCalledInappropriately = 1000;

1037

reeMatchPrimMemoryCorruption = 1001;

1038

reeMatchPrimCorruptedPointers = 1002;

1039

reeNoExpression = 1003;

1040

reeCorruptedProgram = 1004;

1041

reeNoInpitStringSpecified = 1005;

1042

reeOffsetMustBeGreaterThen0 = 1006;

1043

reeExecNextWithoutExec = 1007;

1044

reeGetInputStringWithoutInputString = 1008;

1045

reeDumpCorruptedOpcode = 1011;

1046

reeModifierUnsupported = 1013;

1047

reeLoopStackExceeded = 1014;

1048

reeLoopWithoutEntry = 1015;

1049

reeBadPCodeImported = 2000;

1050

1051

function TRegExpr.ErrorMsg (AErrorID : integer) : RegExprString;

1052

begin

1053

case AErrorID of

1054

reeOk: Result := 'No errors';

1055

reeCompNullArgument: Result := 'TRegExpr(comp): Null Argument';

1056

reeCompRegexpTooBig: Result := 'TRegExpr(comp): Regexp Too Big';

1057

reeCompParseRegTooManyBrackets: Result := 'TRegExpr(comp): ParseReg Too Many ()';

1058

reeCompParseRegUnmatchedBrackets: Result := 'TRegExpr(comp): ParseReg Unmatched ()';

1059

reeCompParseRegUnmatchedBrackets2: Result := 'TRegExpr(comp): ParseReg Unmatched ()';

1060

reeCompParseRegJunkOnEnd: Result := 'TRegExpr(comp): ParseReg Junk On End';

1061

reePlusStarOperandCouldBeEmpty: Result := 'TRegExpr(comp): *+ Operand Could Be Empty';

1062

reeNestedSQP: Result := 'TRegExpr(comp): Nested *?+';

1063

reeBadHexDigit: Result := 'TRegExpr(comp): Bad Hex Digit';

1064

reeInvalidRange: Result := 'TRegExpr(comp): Invalid [] Range';

1065

reeParseAtomTrailingBackSlash: Result := 'TRegExpr(comp): Parse Atom Trailing \';

1066

reeNoHexCodeAfterBSlashX: Result := 'TRegExpr(comp): No Hex Code After \x';

1067

reeHexCodeAfterBSlashXTooBig: Result := 'TRegExpr(comp): Hex Code After \x Is Too Big';

1068

reeUnmatchedSqBrackets: Result := 'TRegExpr(comp): Unmatched []';

1069

reeInternalUrp: Result := 'TRegExpr(comp): Internal Urp';

1070

reeQPSBFollowsNothing: Result := 'TRegExpr(comp): ?+*{ Follows Nothing';

1071

reeTrailingBackSlash: Result := 'TRegExpr(comp): Trailing \';

1072

reeRarseAtomInternalDisaster: Result := 'TRegExpr(comp): RarseAtom Internal Disaster';

1073

reeBRACESArgTooBig: Result := 'TRegExpr(comp): BRACES Argument Too Big';

1074

reeBracesMinParamGreaterMax: Result := 'TRegExpr(comp): BRACE Min Param Greater then Max';

1075

reeUnclosedComment: Result := 'TRegExpr(comp): Unclosed (?#Comment)';

1076

reeComplexBracesNotImplemented: Result := 'TRegExpr(comp): If you want take part in beta-testing BRACES ''{min,max}'' and non-greedy ops ''*?'', ''+?'', ''??'' for complex cases - remove ''.'' from {.$DEFINE ComplexBraces}';

1077

reeUrecognizedModifier: Result := 'TRegExpr(comp): Urecognized Modifier';

1078

reeBadLinePairedSeparator: Result := 'TRegExpr(comp): LinePairedSeparator must countain two different chars or no chars at all';

1079

1080

reeRegRepeatCalledInappropriately: Result := 'TRegExpr(exec): RegRepeat Called Inappropriately';

1081

reeMatchPrimMemoryCorruption: Result := 'TRegExpr(exec): MatchPrim Memory Corruption';

1082

reeMatchPrimCorruptedPointers: Result := 'TRegExpr(exec): MatchPrim Corrupted Pointers';

1083

reeNoExpression: Result := 'TRegExpr(exec): Not Assigned Expression Property';

1084

reeCorruptedProgram: Result := 'TRegExpr(exec): Corrupted Program';

1085

reeNoInpitStringSpecified: Result := 'TRegExpr(exec): No Input String Specified';

1086

reeOffsetMustBeGreaterThen0: Result := 'TRegExpr(exec): Offset Must Be Greater Then 0';

1087

reeExecNextWithoutExec: Result := 'TRegExpr(exec): ExecNext Without Exec[Pos]';

1088

reeGetInputStringWithoutInputString: Result := 'TRegExpr(exec): GetInputString Without InputString';

1089

reeDumpCorruptedOpcode: Result := 'TRegExpr(dump): Corrupted Opcode';

1090

reeLoopStackExceeded: Result := 'TRegExpr(exec): Loop Stack Exceeded';

1091

reeLoopWithoutEntry: Result := 'TRegExpr(exec): Loop Without LoopEntry !';

1092

1093

reeBadPCodeImported: Result := 'TRegExpr(misc): Bad p-code imported';

1094

else Result := 'Unknown error';

1095

end;

1096

end; { of procedure TRegExpr.Error

1097

--------------------------------------------------------------}

1098

1099

function TRegExpr.LastError : integer;

1100

begin

1101

Result := fLastError;

1102

fLastError := reeOk;

1103

end; { of function TRegExpr.LastError

1104

--------------------------------------------------------------}

1105

1106

1107

{=============================================================}

1108

{===================== Common section ========================}

1109

{=============================================================}

1110

1111

class function TRegExpr.VersionMajor : integer; //###0.944

1112

begin

1113

Result := TRegExprVersionMajor;

1114

end; { of class function TRegExpr.VersionMajor

1115

--------------------------------------------------------------}

1116

1117

class function TRegExpr.VersionMinor : integer; //###0.944

1118

begin

1119

Result := TRegExprVersionMinor;

1120

end; { of class function TRegExpr.VersionMinor

1121

--------------------------------------------------------------}

1122

1123

constructor TRegExpr.Create;

1124

begin

1125

inherited;

1126

programm := nil;

1127

fExpression := nil;

1128

fInputString := nil;

1129

1130

regexpbeg := nil;

1131

fExprIsCompiled := false;

1132

1133

ModifierI := RegExprModifierI;

1134

ModifierR := RegExprModifierR;

1135

ModifierS := RegExprModifierS;

1136

ModifierG := RegExprModifierG;

1137

ModifierM := RegExprModifierM; //###0.940

1138

1139

SpaceChars := RegExprSpaceChars; //###0.927

1140

WordChars := RegExprWordChars; //###0.929

1141

fInvertCase := RegExprInvertCaseFunction; //###0.927

1142

1143

fLineSeparators := RegExprLineSeparators; //###0.941

1144

LinePairedSeparator := RegExprLinePairedSeparator; //###0.941

1145

end; { of constructor TRegExpr.Create

1146

--------------------------------------------------------------}

1147

1148

destructor TRegExpr.Destroy;

1149

begin

1150

if programm <> nil

1151

then FreeMem (programm);

1152

if fExpression <> nil

1153

then FreeMem (fExpression);

1154

if fInputString <> nil

1155

then FreeMem (fInputString);

1156

end; { of destructor TRegExpr.Destroy

1157

--------------------------------------------------------------}

1158

1159

class function TRegExpr.InvertCaseFunction (const Ch : REChar) : REChar;

1160

begin

1161

{$IFDEF UniCode}

1162

if Ch >= #128

1163

then Result := Ch

1164

else

1165

{$ENDIF}

1166

begin

1167

Result := {$IFDEF FPC}AnsiUpperCase (Ch) [1]{$ELSE} REChar (CharUpper (PChar (Ch))){$ENDIF};

1168

if Result = Ch

1169

then Result := {$IFDEF FPC}AnsiLowerCase (Ch) [1]{$ELSE} REChar (CharLower (PChar (Ch))){$ENDIF};

1170

end;

1171

end; { of function TRegExpr.InvertCaseFunction

1172

--------------------------------------------------------------}

1173

1174

function TRegExpr.GetExpression : RegExprString;

1175

begin

1176

if fExpression <> nil

1177

then Result := fExpression

1178

else Result := '';

1179

end; { of function TRegExpr.GetExpression

1180

--------------------------------------------------------------}

1181

1182

procedure TRegExpr.SetExpression (const s : RegExprString);

1183

var

1184

Len : integer; //###0.950

1185

begin

1186

if (s <> fExpression) or not fExprIsCompiled then begin

1187

fExprIsCompiled := false;

1188

if fExpression <> nil then begin

1189

FreeMem (fExpression);

1190

fExpression := nil;

1191

end;

1192

if s <> '' then begin

1193

Len := length (s); //###0.950

1194

GetMem (fExpression, (Len + 1) * SizeOf (REChar));

1195

// StrPCopy (fExpression, s); //###0.950 replaced due to StrPCopy limitation of 255 chars

1196

{$IFDEF UniCode}

1197

StrPCopy (fExpression, Copy (s, 1, Len)); //###0.950

1198

{$ELSE}

1199

StrLCopy (fExpression, PRegExprChar (s), Len); //###0.950

1200

{$ENDIF UniCode}

1201

1202

InvalidateProgramm; //###0.941

1203

end;

1204

end;

1205

end; { of procedure TRegExpr.SetExpression

1206

--------------------------------------------------------------}

1207

1208

function TRegExpr.GetSubExprMatchCount : integer;

1209

begin

1210

if Assigned (fInputString) then begin

1211

Result := NSUBEXP - 1;

1212

while (Result > 0) and ((startp [Result] = nil)

1213

or (endp [Result] = nil))

1214

do dec (Result);

1215

end

1216

else Result := -1;

1217

end; { of function TRegExpr.GetSubExprMatchCount

1218

--------------------------------------------------------------}

1219

1220

function TRegExpr.GetMatchPos (Idx : integer) : integer;

1221

begin

1222

if (Idx >= 0) and (Idx < NSUBEXP) and Assigned (fInputString)

1223

and Assigned (startp [Idx]) and Assigned (endp [Idx]) then begin

1224

Result := (startp [Idx] - fInputString) + 1;

1225

end

1226

else Result := -1;

1227

end; { of function TRegExpr.GetMatchPos

1228

--------------------------------------------------------------}

1229

1230

function TRegExpr.GetMatchLen (Idx : integer) : integer;

1231

begin

1232

if (Idx >= 0) and (Idx < NSUBEXP) and Assigned (fInputString)

1233

and Assigned (startp [Idx]) and Assigned (endp [Idx]) then begin

1234

Result := endp [Idx] - startp [Idx];

1235

end

1236

else Result := -1;

1237

end; { of function TRegExpr.GetMatchLen

1238

--------------------------------------------------------------}

1239

1240

function TRegExpr.GetMatch (Idx : integer) : RegExprString;

1241

begin

1242

if (Idx >= 0) and (Idx < NSUBEXP) and Assigned (fInputString)

1243

and Assigned (startp [Idx]) and Assigned (endp [Idx])

1244

//then Result := copy (fInputString, MatchPos [Idx], MatchLen [Idx]) //###0.929

1245

then SetString (Result, startp [idx], endp [idx] - startp [idx])

1246

else Result := '';

1247

end; { of function TRegExpr.GetMatch

1248

--------------------------------------------------------------}

1249

1250

function TRegExpr.GetModifierStr : RegExprString;

1251

begin

1252

Result := '-';

1253

1254

if ModifierI

1255

then Result := 'i' + Result

1256

else Result := Result + 'i';

1257

if ModifierR

1258

then Result := 'r' + Result

1259

else Result := Result + 'r';

1260

if ModifierS

1261

then Result := 's' + Result

1262

else Result := Result + 's';

1263

if ModifierG

1264

then Result := 'g' + Result

1265

else Result := Result + 'g';

1266

if ModifierM

1267

then Result := 'm' + Result

1268

else Result := Result + 'm';

1269

if ModifierX

1270

then Result := 'x' + Result

1271

else Result := Result + 'x';

1272

1273

if Result [length (Result)] = '-' // remove '-' if all modifiers are 'On'

1274

then System.Delete (Result, length (Result), 1);

1275

end; { of function TRegExpr.GetModifierStr

1276

--------------------------------------------------------------}

1277

1278

class function TRegExpr.ParseModifiersStr (const AModifiers : RegExprString;

1279

var AModifiersInt : integer) : boolean;

1280

// !!! Be carefull - this is class function and must not use object instance fields

1281

var

1282

i : integer;

1283

IsOn : boolean;

1284

Mask : integer;

1285

begin

1286

Result := true;

1287

IsOn := true;

1288

Mask := 0; // prevent compiler warning

1289

for i := 1 to length (AModifiers) do

1290

if AModifiers [i] = '-'

1291

then IsOn := false

1292

else begin

1293

if Pos (AModifiers [i], 'iI') > 0

1294

then Mask := MaskModI

1295

else if Pos (AModifiers [i], 'rR') > 0

1296

then Mask := MaskModR

1297

else if Pos (AModifiers [i], 'sS') > 0

1298

then Mask := MaskModS

1299

else if Pos (AModifiers [i], 'gG') > 0

1300

then Mask := MaskModG

1301

else if Pos (AModifiers [i], 'mM') > 0

1302

then Mask := MaskModM

1303

else if Pos (AModifiers [i], 'xX') > 0

1304

then Mask := MaskModX

1305

else begin

1306

Result := false;

1307

EXIT;

1308

end;

1309

if IsOn

1310

then AModifiersInt := AModifiersInt or Mask

1311

else AModifiersInt := AModifiersInt and not Mask;

1312

end;

1313

end; { of function TRegExpr.ParseModifiersStr

1314

--------------------------------------------------------------}

1315

1316

procedure TRegExpr.SetModifierStr (const AModifiers : RegExprString);

1317

begin

1318

if not ParseModifiersStr (AModifiers, fModifiers)

1319

then Error (reeModifierUnsupported);

1320

end; { of procedure TRegExpr.SetModifierStr

1321

--------------------------------------------------------------}

1322

1323

function TRegExpr.GetModifier (AIndex : integer) : boolean;

1324

var

1325

Mask : integer;

1326

begin

1327

Result := false;

1328

case AIndex of

1329

1: Mask := MaskModI;

1330

2: Mask := MaskModR;

1331

3: Mask := MaskModS;

1332

4: Mask := MaskModG;

1333

5: Mask := MaskModM;

1334

6: Mask := MaskModX;

1335

else begin

1336

Error (reeModifierUnsupported);

1337

EXIT;

1338

end;

1339

end;

1340

Result := (fModifiers and Mask) <> 0;

1341

end; { of function TRegExpr.GetModifier

1342

--------------------------------------------------------------}

1343

1344

procedure TRegExpr.SetModifier (AIndex : integer; ASet : boolean);

1345

var

1346

Mask : integer;

1347

begin

1348

case AIndex of

1349

1: Mask := MaskModI;

1350

2: Mask := MaskModR;

1351

3: Mask := MaskModS;

1352

4: Mask := MaskModG;

1353

5: Mask := MaskModM;

1354

6: Mask := MaskModX;

1355

else begin

1356

Error (reeModifierUnsupported);

1357

EXIT;

1358

end;

1359

end;

1360

if ASet

1361

then fModifiers := fModifiers or Mask

1362

else fModifiers := fModifiers and not Mask;

1363

end; { of procedure TRegExpr.SetModifier

1364

--------------------------------------------------------------}

1365

1366

1367

{=============================================================}

1368

{==================== Compiler section =======================}

1369

{=============================================================}

1370

1371

procedure TRegExpr.InvalidateProgramm;

1372

begin

1373

if programm <> nil then begin

1374

FreeMem (programm);

1375

programm := nil;

1376

end;

1377

end; { of procedure TRegExpr.InvalidateProgramm

1378

--------------------------------------------------------------}

1379

1380

procedure TRegExpr.Compile; //###0.941

1381

begin

1382

if fExpression = nil then begin // No Expression assigned

1383

Error (reeNoExpression);

1384

EXIT;

1385

end;

1386

CompileRegExpr (fExpression);

1387

end; { of procedure TRegExpr.Compile

1388

--------------------------------------------------------------}

1389

1390

function TRegExpr.IsProgrammOk : boolean;

1391

{$IFNDEF UniCode}

1392

var

1393

i : integer;

1394

{$ENDIF}

1395

begin

1396

Result := false;

1397

1398

// check modifiers

1399

if fModifiers <> fProgModifiers //###0.941

1400

then InvalidateProgramm;

1401

1402

// can we optimize line separators by using sets?

1403

{$IFNDEF UniCode}

1404

fLineSeparatorsSet := [];

1405

for i := 1 to length (fLineSeparators)

1406

do System.Include (fLineSeparatorsSet, fLineSeparators [i]);

1407

{$ENDIF}

1408

1409

// [Re]compile if needed

1410

if programm = nil

1411

then Compile; //###0.941

1412

1413

// check [re]compiled programm

1414

if programm = nil

1415

then EXIT // error was set/raised by Compile (was reeExecAfterCompErr)

1416

else if programm [0] <> MAGIC // Program corrupted.

1417

then Error (reeCorruptedProgram)

1418

else Result := true;

1419

end; { of function TRegExpr.IsProgrammOk

1420

--------------------------------------------------------------}

1421

1422

procedure TRegExpr.Tail (p : PRegExprChar; val : PRegExprChar);

1423

// set the next-pointer at the end of a node chain

1424

var

1425

scan : PRegExprChar;

1426

temp : PRegExprChar;

1427

// i : int64;

1428

begin

1429

if p = @regdummy

1430

then EXIT;

1431

// Find last node.

1432

scan := p;

1433

REPEAT

1434

temp := regnext (scan);

1435

if temp = nil

1436

then BREAK;

1437

scan := temp;

1438

UNTIL false;

1439

// Set Next 'pointer'

1440

if val < scan

1441

then PRENextOff (scan + REOpSz)^ := - (scan - val) //###0.948

1442

// work around PWideChar subtraction bug (Delphi uses

1443

// shr after subtraction to calculate widechar distance %-( )

1444

// so, if difference is negative we have .. the "feature" :(

1445

// I could wrap it in $IFDEF UniCode, but I didn't because

1446

// "P � Q computes the difference between the address given

1447

// by P (the higher address) and the address given by Q (the

1448

// lower address)" - Delphi help quotation.

1449

else PRENextOff (scan + REOpSz)^ := val - scan; //###0.933

1450

end; { of procedure TRegExpr.Tail

1451

--------------------------------------------------------------}

1452

1453

procedure TRegExpr.OpTail (p : PRegExprChar; val : PRegExprChar);

1454

// regtail on operand of first argument; nop if operandless

1455

begin

1456

// "Operandless" and "op != BRANCH" are synonymous in practice.

1457

if (p = nil) or (p = @regdummy) or (PREOp (p)^ <> BRANCH)

1458

then EXIT;

1459

Tail (p + REOpSz + RENextOffSz, val); //###0.933

1460

end; { of procedure TRegExpr.OpTail

1461

--------------------------------------------------------------}

1462

1463

function TRegExpr.EmitNode (op : TREOp) : PRegExprChar; //###0.933

1464

// emit a node, return location

1465

begin

1466

Result := regcode;

1467

if Result <> @regdummy then begin

1468

PREOp (regcode)^ := op;

1469

inc (regcode, REOpSz);

1470

PRENextOff (regcode)^ := 0; // Next "pointer" := nil

1471

inc (regcode, RENextOffSz);

1472

end

1473

else inc (regsize, REOpSz + RENextOffSz); // compute code size without code generation

1474

end; { of function TRegExpr.EmitNode

1475

--------------------------------------------------------------}

1476

1477

procedure TRegExpr.EmitC (b : REChar);

1478

// emit a byte to code

1479

begin

1480

if regcode <> @regdummy then begin

1481

regcode^ := b;

1482

inc (regcode);

1483

end

1484

else inc (regsize); // Type of p-code pointer always is ^REChar

1485

end; { of procedure TRegExpr.EmitC

1486

--------------------------------------------------------------}

1487

1488

procedure TRegExpr.InsertOperator (op : TREOp; opnd : PRegExprChar; sz : integer);

1489

// insert an operator in front of already-emitted operand

1490

// Means relocating the operand.

1491

var

1492

src, dst, place : PRegExprChar;

1493

i : integer;

1494

begin

1495

if regcode = @regdummy then begin

1496

inc (regsize, sz);

1497

EXIT;

1498

end;

1499

src := regcode;

1500

inc (regcode, sz);

1501

dst := regcode;

1502

while src > opnd do begin

1503

dec (dst);

1504

dec (src);

1505

dst^ := src^;

1506

end;

1507

place := opnd; // Op node, where operand used to be.

1508

PREOp (place)^ := op;

1509

inc (place, REOpSz);

1510

for i := 1 + REOpSz to sz do begin

1511

place^ := #0;

1512

inc (place);

1513

end;

1514

end; { of procedure TRegExpr.InsertOperator

1515

--------------------------------------------------------------}

1516

1517

function strcspn (s1 : PRegExprChar; s2 : PRegExprChar) : integer;

1518

// find length of initial segment of s1 consisting

1519

// entirely of characters not from s2

1520

var scan1, scan2 : PRegExprChar;

1521

begin

1522

Result := 0;

1523

scan1 := s1;

1524

while scan1^ <> #0 do begin

1525

scan2 := s2;

1526

while scan2^ <> #0 do

1527

if scan1^ = scan2^

1528

then EXIT

1529

else inc (scan2);

1530

inc (Result);

1531

inc (scan1)

1532

end;

1533

end; { of function strcspn

1534

--------------------------------------------------------------}

1535

1536

const

1537

// Flags to be passed up and down.

1538

HASWIDTH = 01; // Known never to match nil string.

1539

SIMPLE = 02; // Simple enough to be STAR/PLUS/BRACES operand.

1540

SPSTART = 04; // Starts with * or +.

1541

WORST = 0; // Worst case.

1542

META : array [0 .. 12] of REChar = (

1543

'^', '$', '.', '[', '(', ')', '|', '?', '+', '*', EscChar, '{', #0);

1544

// Any modification must be synchronized with QuoteRegExprMetaChars !!!

1545

1546

{$IFDEF UniCode}

1547

RusRangeLo : array [0 .. 33] of REChar =

1548

(#$430,#$431,#$432,#$433,#$434,#$435,#$451,#$436,#$437,

1549

#$438,#$439,#$43A,#$43B,#$43C,#$43D,#$43E,#$43F,

1550

#$440,#$441,#$442,#$443,#$444,#$445,#$446,#$447,

1551

#$448,#$449,#$44A,#$44B,#$44C,#$44D,#$44E,#$44F,#0);

1552

RusRangeHi : array [0 .. 33] of REChar =

1553

(#$410,#$411,#$412,#$413,#$414,#$415,#$401,#$416,#$417,

1554

#$418,#$419,#$41A,#$41B,#$41C,#$41D,#$41E,#$41F,

1555

#$420,#$421,#$422,#$423,#$424,#$425,#$426,#$427,

1556

#$428,#$429,#$42A,#$42B,#$42C,#$42D,#$42E,#$42F,#0);

1557

RusRangeLoLow = #$430{'�'};

1558

RusRangeLoHigh = #$44F{'�'};

1559

RusRangeHiLow = #$410{'�'};

1560

RusRangeHiHigh = #$42F{'�'};

1561

{$ELSE}

1562

RusRangeLo = '��';

1563

RusRangeHi = '��Ũ��';

1564

RusRangeLoLow = '�';

1565

RusRangeLoHigh = '�';

1566

RusRangeHiLow = '�';

1567

RusRangeHiHigh = '�';

1568

{$ENDIF}

1569

1570

function TRegExpr.CompileRegExpr (exp : PRegExprChar) : boolean;

1571

// compile a regular expression into internal code

1572

// We can't allocate space until we know how big the compiled form will be,

1573

// but we can't compile it (and thus know how big it is) until we've got a

1574

// place to put the code. So we cheat: we compile it twice, once with code

1575

// generation turned off and size counting turned on, and once "for real".

1576

// This also means that we don't allocate space until we are sure that the

1577

// thing really will compile successfully, and we never have to move the

1578

// code and thus invalidate pointers into it. (Note that it has to be in

1579

// one piece because free() must be able to free it all.)

1580

// Beware that the optimization-preparation code in here knows about some

1581

// of the structure of the compiled regexp.

1582

var

1583

scan, longest : PRegExprChar;

1584

len : cardinal;

1585

flags : integer;

1586

begin

1587

Result := false; // life too dark

1588

1589

regparse := nil; // for correct error handling

1590

regexpbeg := exp;

1591

try

1592

1593

if programm <> nil then begin

1594

FreeMem (programm);

1595

programm := nil;

1596

end;

1597

1598

if exp = nil then begin

1599

Error (reeCompNullArgument);

1600

EXIT;

1601

end;

1602

1603

fProgModifiers := fModifiers;

1604

// well, may it's paranoia. I'll check it later... !!!!!!!!

1605

1606

// First pass: determine size, legality.

1607

fCompModifiers := fModifiers;

1608

regparse := exp;

1609

regnpar := 1;

1610

regsize := 0;

1611

regcode := @regdummy;

1612

EmitC (MAGIC);

1613

if ParseReg (0, flags) = nil

1614

then EXIT;

1615

1616

// Small enough for 2-bytes programm pointers ?

1617

// ###0.933 no real p-code length limits now :)))

1618

// if regsize >= 64 * 1024 then begin

1619

// Error (reeCompRegexpTooBig);

1620

// EXIT;

1621

// end;

1622

1623

// Allocate space.

1624

GetMem (programm, regsize * SizeOf (REChar));

1625

1626

// Second pass: emit code.

1627

fCompModifiers := fModifiers;

1628

regparse := exp;

1629

regnpar := 1;

1630

regcode := programm;

1631

EmitC (MAGIC);

1632

if ParseReg (0, flags) = nil

1633

then EXIT;

1634

1635

// Dig out information for optimizations.

1636

{$IFDEF UseFirstCharSet} //###0.929

1637

FirstCharSet := [];

1638

FillFirstCharSet (programm + REOpSz);

1639

{$ENDIF}

1640

regstart := #0; // Worst-case defaults.

1641

reganch := #0;

1642

regmust := nil;

1643

regmlen := 0;

1644

scan := programm + REOpSz; // First BRANCH.

1645

if PREOp (regnext (scan))^ = EEND then begin // Only one top-level choice.

1646

scan := scan + REOpSz + RENextOffSz;

1647

1648

// Starting-point info.

1649

if PREOp (scan)^ = EXACTLY

1650

then regstart := (scan + REOpSz + RENextOffSz)^

1651

else if PREOp (scan)^ = BOL

1652

then inc (reganch);

1653

1654

// If there's something expensive in the r.e., find the longest

1655

// literal string that must appear and make it the regmust. Resolve

1656

// ties in favor of later strings, since the regstart check works

1657

// with the beginning of the r.e. and avoiding duplication

1658

// strengthens checking. Not a strong reason, but sufficient in the

1659

// absence of others.

1660

if (flags and SPSTART) <> 0 then begin

1661

longest := nil;

1662

len := 0;

1663

while scan <> nil do begin

1664

if (PREOp (scan)^ = EXACTLY)

1665

and (strlen (scan + REOpSz + RENextOffSz) >= len) then begin

1666

longest := scan + REOpSz + RENextOffSz;

1667

len := strlen (longest);

1668

end;

1669

scan := regnext (scan);

1670

end;

1671

regmust := longest;

1672

regmlen := len;

1673

end;

1674

end;

1675

1676

Result := true;

1677

1678

finally begin

1679

if not Result

1680

then InvalidateProgramm;

1681

regexpbeg := nil;

1682

fExprIsCompiled := Result; //###0.944

1683

end;

1684

end;

1685

1686

end; { of function TRegExpr.CompileRegExpr

1687

--------------------------------------------------------------}

1688

1689

function TRegExpr.ParseReg (paren : integer; var flagp : integer) : PRegExprChar;

1690

// regular expression, i.e. main body or parenthesized thing

1691

// Caller must absorb opening parenthesis.

1692

// Combining parenthesis handling with the base level of regular expression

1693

// is a trifle forced, but the need to tie the tails of the branches to what

1694

// follows makes it hard to avoid.

1695

var

1696

ret, br, ender : PRegExprChar;

1697

parno : integer;

1698

flags : integer;

1699

SavedModifiers : integer;

1700

begin

1701

Result := nil;

1702

flagp := HASWIDTH; // Tentatively.

1703

parno := 0; // eliminate compiler stupid warning

1704

SavedModifiers := fCompModifiers;

1705

1706

// Make an OPEN node, if parenthesized.

1707

if paren <> 0 then begin

1708

if regnpar >= NSUBEXP then begin

1709

Error (reeCompParseRegTooManyBrackets);

1710

EXIT;

1711

end;

1712

parno := regnpar;

1713

inc (regnpar);

1714

ret := EmitNode (TREOp (ord (OPEN) + parno));

1715

end

1716

else ret := nil;

1717

1718

// Pick up the branches, linking them together.

1719

br := ParseBranch (flags);

1720

if br = nil then begin

1721

Result := nil;

1722

EXIT;

1723

end;

1724

if ret <> nil

1725

then Tail (ret, br) // OPEN -> first.

1726

else ret := br;

1727

if (flags and HASWIDTH) = 0

1728

then flagp := flagp and not HASWIDTH;

1729

flagp := flagp or flags and SPSTART;

1730

while (regparse^ = '|') do begin

1731

inc (regparse);

1732

br := ParseBranch (flags);

1733

if br = nil then begin

1734

Result := nil;

1735

EXIT;

1736

end;

1737

Tail (ret, br); // BRANCH -> BRANCH.

1738

if (flags and HASWIDTH) = 0

1739

then flagp := flagp and not HASWIDTH;

1740

flagp := flagp or flags and SPSTART;

1741

end;

1742

1743

// Make a closing node, and hook it on the end.

1744

if paren <> 0

1745

then ender := EmitNode (TREOp (ord (CLOSE) + parno))

1746

else ender := EmitNode (EEND);

1747

Tail (ret, ender);

1748

1749

// Hook the tails of the branches to the closing node.

1750

br := ret;

1751

while br <> nil do begin

1752

OpTail (br, ender);

1753

br := regnext (br);

1754

end;

1755

1756

// Check for proper termination.

1757

if paren <> 0 then

1758

if regparse^ <> ')' then begin

1759

Error (reeCompParseRegUnmatchedBrackets);

1760

EXIT;

1761

end

1762

else inc (regparse); // skip trailing ')'

1763

if (paren = 0) and (regparse^ <> #0) then begin

1764

if regparse^ = ')'

1765

then Error (reeCompParseRegUnmatchedBrackets2)

1766

else Error (reeCompParseRegJunkOnEnd);

1767

EXIT;

1768

end;

1769

fCompModifiers := SavedModifiers; // restore modifiers of parent

1770

Result := ret;

1771

end; { of function TRegExpr.ParseReg

1772

--------------------------------------------------------------}

1773

1774

function TRegExpr.ParseBranch (var flagp : integer) : PRegExprChar;

1775

// one alternative of an | operator

1776

// Implements the concatenation operator.

1777

var

1778

ret, chain, latest : PRegExprChar;

1779

flags : integer;

1780

begin

1781

flagp := WORST; // Tentatively.

1782

1783

ret := EmitNode (BRANCH);

1784

chain := nil;

1785

while (regparse^ <> #0) and (regparse^ <> '|')

1786

and (regparse^ <> ')') do begin

1787

latest := ParsePiece (flags);

1788

if latest = nil then begin

1789

Result := nil;

1790

EXIT;

1791

end;

1792

flagp := flagp or flags and HASWIDTH;

1793

if chain = nil // First piece.

1794

then flagp := flagp or flags and SPSTART

1795

else Tail (chain, latest);

1796

chain := latest;

1797

end;

1798

if chain = nil // Loop ran zero times.

1799

then EmitNode (NOTHING);

1800

Result := ret;

1801

end; { of function TRegExpr.ParseBranch

1802

--------------------------------------------------------------}

1803

1804

function TRegExpr.ParsePiece (var flagp : integer) : PRegExprChar;

1805

// something followed by possible [*+?{]

1806

// Note that the branching code sequences used for ? and the general cases

1807

// of * and + and { are somewhat optimized: they use the same NOTHING node as

1808

// both the endmarker for their branch list and the body of the last branch.

1809

// It might seem that this node could be dispensed with entirely, but the

1810

// endmarker role is not redundant.

1811

function parsenum (AStart, AEnd : PRegExprChar) : TREBracesArg;

1812

begin

1813

Result := 0;

1814

if AEnd - AStart + 1 > 8 then begin // prevent stupid scanning

1815

Error (reeBRACESArgTooBig);

1816

EXIT;

1817

end;

1818

while AStart <= AEnd do begin

1819

Result := Result * 10 + (ord (AStart^) - ord ('0'));

1820

inc (AStart);

1821

end;

1822

if (Result > MaxBracesArg) or (Result < 0) then begin

1823

Error (reeBRACESArgTooBig);

1824

EXIT;

1825

end;

1826

end;

1827

1828

var

1829

op : REChar;

1830

NonGreedyOp, NonGreedyCh : boolean; //###0.940

1831

TheOp : TREOp; //###0.940

1832

NextNode : PRegExprChar;

1833

flags : integer;

1834

BracesMin, Bracesmax : TREBracesArg;

1835

p, savedparse : PRegExprChar;

1836

1837

procedure EmitComplexBraces (ABracesMin, ABracesMax : TREBracesArg;

1838

ANonGreedyOp : boolean); //###0.940

1839

{$IFDEF ComplexBraces}

1840

var

1841

off : integer;

1842

{$ENDIF}

1843

begin

1844

{$IFNDEF ComplexBraces}

1845

Error (reeComplexBracesNotImplemented);

1846

{$ELSE}

1847

if ANonGreedyOp

1848

then TheOp := LOOPNG

1849

else TheOp := LOOP;

1850

InsertOperator (LOOPENTRY, Result, REOpSz + RENextOffSz);

1851

NextNode := EmitNode (TheOp);

1852

if regcode <> @regdummy then begin

1853

off := (Result + REOpSz + RENextOffSz)

1854

- (regcode - REOpSz - RENextOffSz); // back to Atom after LOOPENTRY

1855

PREBracesArg (regcode)^ := ABracesMin;

1856

inc (regcode, REBracesArgSz);

1857

PREBracesArg (regcode)^ := ABracesMax;

1858

inc (regcode, REBracesArgSz);

1859

PRENextOff (regcode)^ := off;

1860

inc (regcode, RENextOffSz);

1861

end

1862

else inc (regsize, REBracesArgSz * 2 + RENextOffSz);

1863

Tail (Result, NextNode); // LOOPENTRY -> LOOP

1864

if regcode <> @regdummy then

1865

Tail (Result + REOpSz + RENextOffSz, NextNode); // Atom -> LOOP

1866

{$ENDIF}

1867

end;

1868

1869

procedure EmitSimpleBraces (ABracesMin, ABracesMax : TREBracesArg;

1870

ANonGreedyOp : boolean); //###0.940

1871

begin

1872

if ANonGreedyOp //###0.940

1873

then TheOp := BRACESNG

1874

else TheOp := BRACES;

1875

InsertOperator (TheOp, Result, REOpSz + RENextOffSz + REBracesArgSz * 2);

1876

if regcode <> @regdummy then begin

1877

PREBracesArg (Result + REOpSz + RENextOffSz)^ := ABracesMin;

1878

PREBracesArg (Result + REOpSz + RENextOffSz + REBracesArgSz)^ := ABracesMax;

1879

end;

1880

end;

1881

1882

begin

1883

Result := ParseAtom (flags);

1884

if Result = nil

1885

then EXIT;

1886

1887

op := regparse^;

1888

if not ((op = '*') or (op = '+') or (op = '?') or (op = '{')) then begin

1889

flagp := flags;

1890

EXIT;

1891

end;

1892

if ((flags and HASWIDTH) = 0) and (op <> '?') then begin

1893

Error (reePlusStarOperandCouldBeEmpty);

1894

EXIT;

1895

end;

1896

1897

case op of

1898

'*': begin

1899

flagp := WORST or SPSTART;

1900

NonGreedyCh := (regparse + 1)^ = '?'; //###0.940

1901

NonGreedyOp := NonGreedyCh or ((fCompModifiers and MaskModG) = 0); //###0.940

1902

if (flags and SIMPLE) = 0 then begin

1903

if NonGreedyOp //###0.940

1904

then EmitComplexBraces (0, MaxBracesArg, NonGreedyOp)

1905

else begin // Emit x* as (x&|), where & means "self".

1906

InsertOperator (BRANCH, Result, REOpSz + RENextOffSz); // Either x

1907

OpTail (Result, EmitNode (BACK)); // and loop

1908

OpTail (Result, Result); // back

1909

Tail (Result, EmitNode (BRANCH)); // or

1910

Tail (Result, EmitNode (NOTHING)); // nil.

1911

end

1912

end

1913

else begin // Simple

1914

if NonGreedyOp //###0.940

1915

then TheOp := STARNG

1916

else TheOp := STAR;

1917

InsertOperator (TheOp, Result, REOpSz + RENextOffSz);

1918

end;

1919

if NonGreedyCh //###0.940

1920

then inc (regparse); // Skip extra char ('?')

1921

end; { of case '*'}

1922

'+': begin

1923

flagp := WORST or SPSTART or HASWIDTH;

1924

NonGreedyCh := (regparse + 1)^ = '?'; //###0.940

1925

NonGreedyOp := NonGreedyCh or ((fCompModifiers and MaskModG) = 0); //###0.940

1926

if (flags and SIMPLE) = 0 then begin

1927

if NonGreedyOp //###0.940

1928

then EmitComplexBraces (1, MaxBracesArg, NonGreedyOp)

1929

else begin // Emit x+ as x(&|), where & means "self".

1930

NextNode := EmitNode (BRANCH); // Either

1931

Tail (Result, NextNode);

1932

Tail (EmitNode (BACK), Result); // loop back

1933

Tail (NextNode, EmitNode (BRANCH)); // or

1934

Tail (Result, EmitNode (NOTHING)); // nil.

1935

end

1936

end

1937

else begin // Simple

1938

if NonGreedyOp //###0.940

1939

then TheOp := PLUSNG

1940

else TheOp := PLUS;

1941

InsertOperator (TheOp, Result, REOpSz + RENextOffSz);

1942

end;

1943

if NonGreedyCh //###0.940

1944

then inc (regparse); // Skip extra char ('?')

1945

end; { of case '+'}

1946

'?': begin

1947

flagp := WORST;

1948

NonGreedyCh := (regparse + 1)^ = '?'; //###0.940

1949

NonGreedyOp := NonGreedyCh or ((fCompModifiers and MaskModG) = 0); //###0.940

1950

if NonGreedyOp then begin //###0.940 // We emit x?? as x{0,1}?

1951

if (flags and SIMPLE) = 0

1952

then EmitComplexBraces (0, 1, NonGreedyOp)

1953

else EmitSimpleBraces (0, 1, NonGreedyOp);

1954

end

1955

else begin // greedy '?'

1956

InsertOperator (BRANCH, Result, REOpSz + RENextOffSz); // Either x

1957

Tail (Result, EmitNode (BRANCH)); // or

1958

NextNode := EmitNode (NOTHING); // nil.

1959

Tail (Result, NextNode);

1960

OpTail (Result, NextNode);

1961

end;

1962

if NonGreedyCh //###0.940

1963

then inc (regparse); // Skip extra char ('?')

1964

end; { of case '?'}

1965

'{': begin

1966

savedparse := regparse;

1967

// !!!!!!!!!!!!

1968

// Filip Jirsak's note - what will happen, when we are at the end of regparse?

1969

inc (regparse);

1970

p := regparse;

1971

while Pos (regparse^, '0123456789') > 0 // <min> MUST appear

1972

do inc (regparse);

1973

if (regparse^ <> '}') and (regparse^ <> ',') or (p = regparse) then begin

1974

regparse := savedparse;

1975

flagp := flags;

1976

EXIT;

1977

end;

1978

BracesMin := parsenum (p, regparse - 1);

1979

if regparse^ = ',' then begin

1980

inc (regparse);

1981

p := regparse;

1982

while Pos (regparse^, '0123456789') > 0

1983

do inc (regparse);

1984

if regparse^ <> '}' then begin

1985

regparse := savedparse;

1986

EXIT;

1987

end;

1988

if p = regparse

1989

then BracesMax := MaxBracesArg

1990

else BracesMax := parsenum (p, regparse - 1);

1991

end

1992

else BracesMax := BracesMin; // {n} == {n,n}

1993

if BracesMin > BracesMax then begin

1994

Error (reeBracesMinParamGreaterMax);

1995

EXIT;

1996

end;

1997

if BracesMin > 0

1998

then flagp := WORST;

1999

if BracesMax > 0

2000

then flagp := flagp or HASWIDTH or SPSTART;

2001

2002

NonGreedyCh := (regparse + 1)^ = '?'; //###0.940

2003

NonGreedyOp := NonGreedyCh or ((fCompModifiers and MaskModG) = 0); //###0.940

2004

if (flags and SIMPLE) <> 0

2005

then EmitSimpleBraces (BracesMin, BracesMax, NonGreedyOp)

2006

else EmitComplexBraces (BracesMin, BracesMax, NonGreedyOp);

2007

if NonGreedyCh //###0.940

2008

then inc (regparse); // Skip extra char '?'

2009

end; { of case '{'}

2010

// else // here we can't be

2011

end; { of case op}

2012

2013

inc (regparse);

2014

if (regparse^ = '*') or (regparse^ = '+') or (regparse^ = '?') or (regparse^ = '{') then begin

2015

Error (reeNestedSQP);

2016

EXIT;

2017

end;

2018

end; { of function TRegExpr.ParsePiece

2019

--------------------------------------------------------------}

2020

2021

function TRegExpr.ParseAtom (var flagp : integer) : PRegExprChar;

2022

// the lowest level

2023

// Optimization: gobbles an entire sequence of ordinary characters so that

2024

// it can turn them into a single node, which is smaller to store and

2025

// faster to run. Backslashed characters are exceptions, each becoming a

2026

// separate node; the code is simpler that way and it's not worth fixing.

2027

var

2028

ret : PRegExprChar;

2029

flags : integer;

2030

RangeBeg, RangeEnd : REChar;

2031

CanBeRange : boolean;

2032

len : integer;

2033

ender : REChar;

2034

begmodfs : PRegExprChar;

2035

2036

{$IFDEF UseSetOfChar} //###0.930

2037

RangePCodeBeg : PRegExprChar;

2038

RangePCodeIdx : integer;

2039

RangeIsCI : boolean;

2040

RangeSet : TSetOfREChar;

2041

RangeLen : integer;

2042

RangeChMin, RangeChMax : REChar;

2043

{$ENDIF}

2044

2045

procedure EmitExactly (ch : REChar);

2046

begin

2047

if (fCompModifiers and MaskModI) <> 0

2048

then ret := EmitNode (EXACTLYCI)

2049

else ret := EmitNode (EXACTLY);

2050

EmitC (ch);

2051

EmitC (#0);

2052

flagp := flagp or HASWIDTH or SIMPLE;

2053

end;

2054

2055

procedure EmitStr (const s : RegExprString);

2056

var i : integer;

2057

begin

2058

for i := 1 to length (s)

2059

do EmitC (s [i]);

2060

end;

2061

2062

function HexDig (ch : REChar) : integer;

2063

begin

2064

Result := 0;

2065

if (ch >= 'a') and (ch <= 'f')

2066

then ch := REChar (ord (ch) - (ord ('a') - ord ('A')));

2067

if (ch < '0') or (ch > 'F') or ((ch > '9') and (ch < 'A')) then begin

2068

Error (reeBadHexDigit);

2069

EXIT;

2070

end;

2071

Result := ord (ch) - ord ('0');

2072

if ch >= 'A'

2073

then Result := Result - (ord ('A') - ord ('9') - 1);

2074

end;

2075

2076

function EmitRange (AOpCode : REChar) : PRegExprChar;

2077

begin

2078

{$IFDEF UseSetOfChar}

2079

case AOpCode of

2080

ANYBUTCI, ANYBUT:

2081

Result := EmitNode (ANYBUTTINYSET);

2082

else // ANYOFCI, ANYOF

2083

Result := EmitNode (ANYOFTINYSET);

2084

end;

2085

case AOpCode of

2086

ANYBUTCI, ANYOFCI:

2087

RangeIsCI := True;

2088

else // ANYBUT, ANYOF

2089

RangeIsCI := False;

2090

end;

2091

RangePCodeBeg := regcode;

2092

RangePCodeIdx := regsize;

2093

RangeLen := 0;

2094

RangeSet := [];

2095

RangeChMin := #255;

2096

RangeChMax := #0;

2097

{$ELSE}

2098

Result := EmitNode (AOpCode);

2099

// ToDo:

2100

// !!!!!!!!!!!!! Implement ANYOF[BUT]TINYSET generation for UniCode !!!!!!!!!!

2101

{$ENDIF}

2102

end;

2103

2104

{$IFDEF UseSetOfChar}

2105

procedure EmitRangeCPrim (b : REChar); //###0.930

2106

begin

2107

if b in RangeSet

2108

then EXIT;

2109

inc (RangeLen);

2110

if b < RangeChMin

2111

then RangeChMin := b;

2112

if b > RangeChMax

2113

then RangeChMax := b;

2114

Include (RangeSet, b);

2115

end;

2116

{$ENDIF}

2117

2118

procedure EmitRangeC (b : REChar);

2119

{$IFDEF UseSetOfChar}

2120

var

2121

Ch : REChar;

2122

{$ENDIF}

2123

begin

2124

CanBeRange := false;

2125

{$IFDEF UseSetOfChar}

2126

if b <> #0 then begin

2127

EmitRangeCPrim (b); //###0.930

2128

if RangeIsCI

2129

then EmitRangeCPrim (InvertCase (b)); //###0.930

2130

end

2131

else begin

2132

{$IFDEF UseAsserts}

2133

Assert (RangeLen > 0, 'TRegExpr.ParseAtom(subroutine EmitRangeC): empty range'); // impossible, but who knows..

2134

Assert (RangeChMin <= RangeChMax, 'TRegExpr.ParseAtom(subroutine EmitRangeC): RangeChMin > RangeChMax'); // impossible, but who knows..

2135

{$ENDIF}

2136

if RangeLen <= TinySetLen then begin // emit "tiny set"

2137

if regcode = @regdummy then begin

2138

regsize := RangePCodeIdx + TinySetLen; // RangeChMin/Max !!!

2139

EXIT;

2140

end;

2141

regcode := RangePCodeBeg;

2142

for Ch := RangeChMin to RangeChMax do //###0.930

2143

if Ch in RangeSet then begin

2144

regcode^ := Ch;

2145

inc (regcode);

2146

end;

2147

// fill rest:

2148

while regcode < RangePCodeBeg + TinySetLen do begin

2149

regcode^ := RangeChMax;

2150

inc (regcode);

2151

end;

2152

end

2153

else begin

2154

if regcode = @regdummy then begin

2155

regsize := RangePCodeIdx + SizeOf (TSetOfREChar);

2156

EXIT;

2157

end;

2158

if (RangePCodeBeg - REOpSz - RENextOffSz)^ = ANYBUTTINYSET

2159

then RangeSet := [#0 .. #255] - RangeSet;

2160

PREOp (RangePCodeBeg - REOpSz - RENextOffSz)^ := ANYOFFULLSET;

2161

regcode := RangePCodeBeg;

2162

Move (RangeSet, regcode^, SizeOf (TSetOfREChar));

2163

inc (regcode, SizeOf (TSetOfREChar));

2164

end;

2165

end;

2166

{$ELSE}

2167

EmitC (b);

2168

{$ENDIF}

2169

end;

2170

2171

procedure EmitSimpleRangeC (b : REChar);

2172

begin

2173

RangeBeg := b;

2174

EmitRangeC (b);

2175

CanBeRange := true;

2176

end;

2177

2178

procedure EmitRangeStr (const s : RegExprString);

2179

var i : integer;

2180

begin

2181

for i := 1 to length (s)

2182

do EmitRangeC (s [i]);

2183

end;

2184

2185

function UnQuoteChar (var APtr : PRegExprChar) : REChar; //###0.934

2186

begin

2187

case APtr^ of

2188

't': Result := #$9; // tab (HT/TAB)

2189

'n': Result := #$a; // newline (NL)

2190

'r': Result := #$d; // car.return (CR)

2191

'f': Result := #$c; // form feed (FF)

2192

'a': Result := #$7; // alarm (bell) (BEL)

2193

'e': Result := #$1b; // escape (ESC)

2194

'x': begin // hex char

2195

Result := #0;

2196

inc (APtr);

2197

if APtr^ = #0 then begin

2198

Error (reeNoHexCodeAfterBSlashX);

2199

EXIT;

2200

end;

2201

if APtr^ = '{' then begin // \x{nnnn} //###0.936

2202

REPEAT

2203

inc (APtr);

2204

if APtr^ = #0 then begin

2205

Error (reeNoHexCodeAfterBSlashX);

2206

EXIT;

2207

end;

2208

if APtr^ <> '}' then begin

2209

if (Ord (Result)

2210

ShR (SizeOf (REChar) * 8 - 4)) and $F <> 0 then begin

2211

Error (reeHexCodeAfterBSlashXTooBig);

2212

EXIT;

2213

end;

2214

Result := REChar ((Ord (Result) ShL 4) or HexDig (APtr^));

2215

// HexDig will cause Error if bad hex digit found

2216

end

2217

else BREAK;

2218

UNTIL False;

2219

end

2220

else begin

2221

Result := REChar (HexDig (APtr^));

2222

// HexDig will cause Error if bad hex digit found

2223

inc (APtr);

2224

if APtr^ = #0 then begin

2225

Error (reeNoHexCodeAfterBSlashX);

2226

EXIT;

2227

end;

2228

Result := REChar ((Ord (Result) ShL 4) or HexDig (APtr^));

2229

// HexDig will cause Error if bad hex digit found

2230

end;

2231

end;

2232

else Result := APtr^;

2233

end;

2234

end;

2235

2236

begin

2237

Result := nil;

2238

flagp := WORST; // Tentatively.

2239

2240

inc (regparse);

2241

case (regparse - 1)^ of

2242

'^': if ((fCompModifiers and MaskModM) = 0)

2243

or ((fLineSeparators = '') and not fLinePairedSeparatorAssigned)

2244

then ret := EmitNode (BOL)

2245

else ret := EmitNode (BOLML);

2246

'$': if ((fCompModifiers and MaskModM) = 0)

2247

or ((fLineSeparators = '') and not fLinePairedSeparatorAssigned)

2248

then ret := EmitNode (EOL)

2249

else ret := EmitNode (EOLML);

2250

'.':

2251

if (fCompModifiers and MaskModS) <> 0 then begin

2252

ret := EmitNode (ANY);

2253

flagp := flagp or HASWIDTH or SIMPLE;

2254

end

2255

else begin // not /s, so emit [^:LineSeparators:]

2256

ret := EmitNode (ANYML);

2257

flagp := flagp or HASWIDTH; // not so simple ;)

2258

// ret := EmitRange (ANYBUT);

2259

// EmitRangeStr (LineSeparators); //###0.941

2260

// EmitRangeStr (LinePairedSeparator); // !!! isn't correct if have to accept only paired

2261

// EmitRangeC (#0);

2262

// flagp := flagp or HASWIDTH or SIMPLE;

2263

end;

2264

'[': begin

2265

if regparse^ = '^' then begin // Complement of range.

2266

if (fCompModifiers and MaskModI) <> 0

2267

then ret := EmitRange (ANYBUTCI)

2268

else ret := EmitRange (ANYBUT);

2269

inc (regparse);

2270

end

2271

else

2272

if (fCompModifiers and MaskModI) <> 0

2273

then ret := EmitRange (ANYOFCI)

2274

else ret := EmitRange (ANYOF);

2275

2276

CanBeRange := false;

2277

2278

if (regparse^ = ']') then begin

2279

EmitSimpleRangeC (regparse^); // []-a] -> ']' .. 'a'

2280

inc (regparse);

2281

end;

2282

2283

while (regparse^ <> #0) and (regparse^ <> ']') do begin

2284

if (regparse^ = '-')

2285

and ((regparse + 1)^ <> #0) and ((regparse + 1)^ <> ']')

2286

and CanBeRange then begin

2287

inc (regparse);

2288

RangeEnd := regparse^;

2289

if RangeEnd = EscChar then begin

2290

{$IFDEF UniCode} //###0.935

2291

if (ord ((regparse + 1)^) < 256)

2292

and (char ((regparse + 1)^)

2293

in ['d', 'D', 's', 'S', 'w', 'W']) then begin

2294

{$ELSE}

2295

if (regparse + 1)^ in ['d', 'D', 's', 'S', 'w', 'W'] then begin

2296

{$ENDIF}

2297

EmitRangeC ('-'); // or treat as error ?!!

2298

CONTINUE;

2299

end;

2300

inc (regparse);

2301

RangeEnd := UnQuoteChar (regparse);

2302

end;

2303

2304

// r.e.ranges extension for russian

2305

if ((fCompModifiers and MaskModR) <> 0)

2306

and (RangeBeg = RusRangeLoLow) and (RangeEnd = RusRangeLoHigh) then begin

2307

EmitRangeStr (RusRangeLo);

2308

end

2309

else if ((fCompModifiers and MaskModR) <> 0)

2310

and (RangeBeg = RusRangeHiLow) and (RangeEnd = RusRangeHiHigh) then begin

2311

EmitRangeStr (RusRangeHi);

2312

end

2313

else if ((fCompModifiers and MaskModR) <> 0)

2314

and (RangeBeg = RusRangeLoLow) and (RangeEnd = RusRangeHiHigh) then begin

2315

EmitRangeStr (RusRangeLo);

2316

EmitRangeStr (RusRangeHi);

2317

end

2318

else begin // standard r.e. handling

2319

if RangeBeg > RangeEnd then begin

2320

Error (reeInvalidRange);

2321

EXIT;

2322

end;

2323

inc (RangeBeg);

2324

EmitRangeC (RangeEnd); // prevent infinite loop if RangeEnd=$ff

2325

while RangeBeg < RangeEnd do begin //###0.929

2326

EmitRangeC (RangeBeg);

2327

inc (RangeBeg);

2328

end;

2329

end;

2330

inc (regparse);

2331

end

2332

else begin

2333

if regparse^ = EscChar then begin

2334

inc (regparse);

2335

if regparse^ = #0 then begin

2336

Error (reeParseAtomTrailingBackSlash);

2337

EXIT;

2338

end;

2339

case regparse^ of // r.e.extensions

2340

'd': EmitRangeStr ('0123456789');

2341

'w': EmitRangeStr (WordChars);

2342

's': EmitRangeStr (SpaceChars);

2343

else EmitSimpleRangeC (UnQuoteChar (regparse));

2344

end; { of case}

2345

end

2346

else EmitSimpleRangeC (regparse^);

2347

inc (regparse);

2348

end;

2349

end; { of while}

2350

EmitRangeC (#0);

2351

if regparse^ <> ']' then begin

2352

Error (reeUnmatchedSqBrackets);

2353

EXIT;

2354

end;

2355

inc (regparse);

2356

flagp := flagp or HASWIDTH or SIMPLE;

2357

end;

2358

'(': begin

2359

if regparse^ = '?' then begin

2360

// check for extended Perl syntax : (?..)

2361

if (regparse + 1)^ = '#' then begin // (?#comment)

2362

inc (regparse, 2); // find closing ')'

2363

while (regparse^ <> #0) and (regparse^ <> ')')

2364

do inc (regparse);

2365

if regparse^ <> ')' then begin

2366

Error (reeUnclosedComment);

2367

EXIT;

2368

end;

2369

inc (regparse); // skip ')'

2370

ret := EmitNode (COMMENT); // comment

2371

end

2372

else begin // modifiers ?

2373

inc (regparse); // skip '?'

2374

begmodfs := regparse;

2375

while (regparse^ <> #0) and (regparse^ <> ')')

2376

do inc (regparse);

2377

if (regparse^ <> ')')

2378

or not ParseModifiersStr (copy (begmodfs, 1, (regparse - begmodfs)), fCompModifiers) then begin

2379

Error (reeUrecognizedModifier);

2380

EXIT;

2381

end;

2382

inc (regparse); // skip ')'

2383

ret := EmitNode (COMMENT); // comment

2384

// Error (reeQPSBFollowsNothing);

2385

// EXIT;

2386

end;

2387

end

2388

else begin

2389

ret := ParseReg (1, flags);

2390

if ret = nil then begin

2391

Result := nil;

2392

EXIT;

2393

end;

2394

flagp := flagp or flags and (HASWIDTH or SPSTART);

2395

end;

2396

end;

2397

#0, '|', ')': begin // Supposed to be caught earlier.

2398

Error (reeInternalUrp);

2399

EXIT;

2400

end;

2401

'?', '+', '*': begin

2402

Error (reeQPSBFollowsNothing);

2403

EXIT;

2404

end;

2405

EscChar: begin

2406

if regparse^ = #0 then begin

2407

Error (reeTrailingBackSlash);

2408

EXIT;

2409

end;

2410

case regparse^ of // r.e.extensions

2411

'b': ret := EmitNode (BOUND); //###0.943

2412

'B': ret := EmitNode (NOTBOUND); //###0.943

2413

'A': ret := EmitNode (BOL); //###0.941

2414

'Z': ret := EmitNode (EOL); //###0.941

2415

'd': begin // r.e.extension - any digit ('0' .. '9')

2416

ret := EmitNode (ANYDIGIT);

2417

flagp := flagp or HASWIDTH or SIMPLE;

2418

end;

2419

'D': begin // r.e.extension - not digit ('0' .. '9')

2420

ret := EmitNode (NOTDIGIT);

2421

flagp := flagp or HASWIDTH or SIMPLE;

2422

end;

2423

's': begin // r.e.extension - any space char

2424

{$IFDEF UseSetOfChar}

2425

ret := EmitRange (ANYOF);

2426

EmitRangeStr (SpaceChars);

2427

EmitRangeC (#0);

2428

{$ELSE}

2429

ret := EmitNode (ANYSPACE);

2430

{$ENDIF}

2431

flagp := flagp or HASWIDTH or SIMPLE;

2432

end;

2433

'S': begin // r.e.extension - not space char

2434

{$IFDEF UseSetOfChar}

2435

ret := EmitRange (ANYBUT);

2436

EmitRangeStr (SpaceChars);

2437

EmitRangeC (#0);

2438

{$ELSE}

2439

ret := EmitNode (NOTSPACE);

2440

{$ENDIF}

2441

flagp := flagp or HASWIDTH or SIMPLE;

2442

end;

2443

'w': begin // r.e.extension - any english char / digit / '_'

2444

{$IFDEF UseSetOfChar}

2445

ret := EmitRange (ANYOF);

2446

EmitRangeStr (WordChars);

2447

EmitRangeC (#0);

2448

{$ELSE}

2449

ret := EmitNode (ANYLETTER);

2450

{$ENDIF}

2451

flagp := flagp or HASWIDTH or SIMPLE;

2452

end;

2453

'W': begin // r.e.extension - not english char / digit / '_'

2454

{$IFDEF UseSetOfChar}

2455

ret := EmitRange (ANYBUT);

2456

EmitRangeStr (WordChars);

2457

EmitRangeC (#0);

2458

{$ELSE}

2459

ret := EmitNode (NOTLETTER);

2460

{$ENDIF}

2461

flagp := flagp or HASWIDTH or SIMPLE;

2462

end;

2463

'1' .. '9': begin //###0.936

2464

if (fCompModifiers and MaskModI) <> 0

2465

then ret := EmitNode (BSUBEXPCI)

2466

else ret := EmitNode (BSUBEXP);

2467

EmitC (REChar (ord (regparse^) - ord ('0')));

2468

flagp := flagp or HASWIDTH or SIMPLE;

2469

end;

2470

else EmitExactly (UnQuoteChar (regparse));

2471

end; { of case}

2472

inc (regparse);

2473

end;

2474

else begin

2475

dec (regparse);

2476

if ((fCompModifiers and MaskModX) <> 0) and // check for eXtended syntax

2477

((regparse^ = '#')

2478

or ({$IFDEF UniCode}StrScan (XIgnoredChars, regparse^) <> nil //###0.947

2479

{$ELSE}regparse^ in XIgnoredChars{$ENDIF})) then begin //###0.941 \x

2480

if regparse^ = '#' then begin // Skip eXtended comment

2481

// find comment terminator (group of \n and/or \r)

2482

while (regparse^ <> #0) and (regparse^ <> #$d) and (regparse^ <> #$a)

2483

do inc (regparse);

2484

while (regparse^ = #$d) or (regparse^ = #$a) // skip comment terminator

2485

do inc (regparse); // attempt to support different type of line separators

2486

end

2487

else begin // Skip the blanks!

2488

while {$IFDEF UniCode}StrScan (XIgnoredChars, regparse^) <> nil //###0.947

2489

{$ELSE}regparse^ in XIgnoredChars{$ENDIF}

2490

do inc (regparse);

2491

end;

2492

ret := EmitNode (COMMENT); // comment

2493

end

2494

else begin

2495

len := strcspn (regparse, META);

2496

if len <= 0 then

2497

if regparse^ <> '{' then begin

2498

Error (reeRarseAtomInternalDisaster);

2499

EXIT;

2500

end

2501

else len := strcspn (regparse + 1, META) + 1; // bad {n,m} - compile as EXATLY

2502

ender := (regparse + len)^;

2503

if (len > 1)

2504

and ((ender = '*') or (ender = '+') or (ender = '?') or (ender = '{'))

2505

then dec (len); // Back off clear of ?+*{ operand.

2506

flagp := flagp or HASWIDTH;

2507

if len = 1

2508

then flagp := flagp or SIMPLE;

2509

if (fCompModifiers and MaskModI) <> 0

2510

then ret := EmitNode (EXACTLYCI)

2511

else ret := EmitNode (EXACTLY);

2512

while (len > 0)

2513

and (((fCompModifiers and MaskModX) = 0) or (regparse^ <> '#')) do begin

2514

if ((fCompModifiers and MaskModX) = 0) or not ( //###0.941

2515

{$IFDEF UniCode}StrScan (XIgnoredChars, regparse^) <> nil //###0.947

2516

{$ELSE}regparse^ in XIgnoredChars{$ENDIF} )

2517

then EmitC (regparse^);

2518

inc (regparse);

2519

dec (len);

2520

end;

2521

EmitC (#0);

2522

end; { of if not comment}

2523

end; { of case else}

2524

end; { of case}

2525

2526

Result := ret;

2527

end; { of function TRegExpr.ParseAtom

2528

--------------------------------------------------------------}

2529

2530

function TRegExpr.GetCompilerErrorPos : integer;

2531

begin

2532

Result := 0;

2533

if (regexpbeg = nil) or (regparse = nil)

2534

then EXIT; // not in compiling mode ?

2535

Result := regparse - regexpbeg;

2536

end; { of function TRegExpr.GetCompilerErrorPos

2537

--------------------------------------------------------------}

2538

2539

2540

{=============================================================}

2541

{===================== Matching section ======================}

2542

{=============================================================}

2543

2544

{$IFNDEF UseSetOfChar}

2545

function TRegExpr.StrScanCI (s : PRegExprChar; ch : REChar) : PRegExprChar; //###0.928 - now method of TRegExpr

2546

begin

2547

while (s^ <> #0) and (s^ <> ch) and (s^ <> InvertCase (ch))

2548

do inc (s);

2549

if s^ <> #0

2550

then Result := s

2551

else Result := nil;

2552

end; { of function TRegExpr.StrScanCI

2553

--------------------------------------------------------------}

2554

{$ENDIF}

2555

2556

function TRegExpr.regrepeat (p : PRegExprChar; AMax : integer) : integer;

2557

// repeatedly match something simple, report how many

2558

var

2559

scan : PRegExprChar;

2560

opnd : PRegExprChar;

2561

TheMax : integer;

2562

{Ch,} InvCh : REChar; //###0.931

2563

sestart, seend : PRegExprChar; //###0.936

2564

begin

2565

Result := 0;

2566

scan := reginput;

2567

opnd := p + REOpSz + RENextOffSz; //OPERAND

2568

TheMax := fInputEnd - scan;

2569

if TheMax > AMax

2570

then TheMax := AMax;

2571

case PREOp (p)^ of

2572

ANY: begin

2573

// note - ANYML cannot be proceeded in regrepeat because can skip

2574

// more than one char at once

2575

Result := TheMax;

2576

inc (scan, Result);

2577

end;

2578

EXACTLY: begin // in opnd can be only ONE char !!!

2579

// Ch := opnd^; // store in register //###0.931

2580

while (Result < TheMax) and (opnd^ = scan^) do begin

2581

inc (Result);

2582

inc (scan);

2583

end;

2584

end;

2585

EXACTLYCI: begin // in opnd can be only ONE char !!!

2586

// Ch := opnd^; // store in register //###0.931

2587

while (Result < TheMax) and (opnd^ = scan^) do begin // prevent unneeded InvertCase //###0.931

2588

inc (Result);

2589

inc (scan);

2590

end;

2591

if Result < TheMax then begin //###0.931

2592

InvCh := InvertCase (opnd^); // store in register

2593

while (Result < TheMax) and

2594

((opnd^ = scan^) or (InvCh = scan^)) do begin

2595

inc (Result);

2596

inc (scan);

2597

end;

2598

end;

2599

end;

2600

BSUBEXP: begin //###0.936

2601

sestart := startp [ord (opnd^)];

2602

if sestart = nil

2603

then EXIT;

2604

seend := endp [ord (opnd^)];

2605

if seend = nil

2606

then EXIT;

2607

REPEAT

2608

opnd := sestart;

2609

while opnd < seend do begin

2610

if (scan >= fInputEnd) or (scan^ <> opnd^)

2611

then EXIT;

2612

inc (scan);

2613

inc (opnd);

2614

end;

2615

inc (Result);

2616

reginput := scan;

2617

UNTIL Result >= AMax;

2618

end;

2619

BSUBEXPCI: begin //###0.936

2620

sestart := startp [ord (opnd^)];

2621

if sestart = nil

2622

then EXIT;

2623

seend := endp [ord (opnd^)];

2624

if seend = nil

2625

then EXIT;

2626

REPEAT

2627

opnd := sestart;

2628

while opnd < seend do begin

2629

if (scan >= fInputEnd) or

2630

((scan^ <> opnd^) and (scan^ <> InvertCase (opnd^)))

2631

then EXIT;

2632

inc (scan);

2633

inc (opnd);

2634

end;

2635

inc (Result);

2636

reginput := scan;

2637

UNTIL Result >= AMax;

2638

end;

2639

ANYDIGIT:

2640

while (Result < TheMax) and

2641

(scan^ >= '0') and (scan^ <= '9') do begin

2642

inc (Result);

2643

inc (scan);

2644

end;

2645

NOTDIGIT:

2646

while (Result < TheMax) and

2647

((scan^ < '0') or (scan^ > '9')) do begin

2648

inc (Result);

2649

inc (scan);

2650

end;

2651

{$IFNDEF UseSetOfChar} //###0.929

2652

ANYLETTER:

2653

while (Result < TheMax) and

2654

(Pos (scan^, fWordChars) > 0) //###0.940

2655

{ ((scan^ >= 'a') and (scan^ <= 'z') !! I've forgotten (>='0') and (<='9')

2656

or (scan^ >= 'A') and (scan^ <= 'Z') or (scan^ = '_'))} do begin

2657

inc (Result);

2658

inc (scan);

2659

end;

2660

NOTLETTER:

2661

while (Result < TheMax) and

2662

(Pos (scan^, fWordChars) <= 0) //###0.940

2663

{ not ((scan^ >= 'a') and (scan^ <= 'z') !! I've forgotten (>='0') and (<='9')

2664

or (scan^ >= 'A') and (scan^ <= 'Z')

2665

or (scan^ = '_'))} do begin

2666

inc (Result);

2667

inc (scan);

2668

end;

2669

ANYSPACE:

2670

while (Result < TheMax) and

2671

(Pos (scan^, fSpaceChars) > 0) do begin

2672

inc (Result);

2673

inc (scan);

2674

end;

2675

NOTSPACE:

2676

while (Result < TheMax) and

2677

(Pos (scan^, fSpaceChars) <= 0) do begin

2678

inc (Result);

2679

inc (scan);

2680

end;

2681

{$ENDIF}

2682

ANYOFTINYSET: begin

2683

while (Result < TheMax) and //!!!TinySet

2684

((scan^ = opnd^) or (scan^ = (opnd + 1)^)

2685

or (scan^ = (opnd + 2)^)) do begin

2686

inc (Result);

2687

inc (scan);

2688

end;

2689

end;

2690

ANYBUTTINYSET: begin

2691

while (Result < TheMax) and //!!!TinySet

2692

(scan^ <> opnd^) and (scan^ <> (opnd + 1)^)

2693

and (scan^ <> (opnd + 2)^) do begin

2694

inc (Result);

2695

inc (scan);

2696

end;

2697

end;

2698

{$IFDEF UseSetOfChar} //###0.929

2699

ANYOFFULLSET: begin

2700

while (Result < TheMax) and

2701

(scan^ in PSetOfREChar (opnd)^) do begin

2702

inc (Result);

2703

inc (scan);

2704

end;

2705

end;

2706

{$ELSE}

2707

ANYOF:

2708

while (Result < TheMax) and

2709

(StrScan (opnd, scan^) <> nil) do begin

2710

inc (Result);

2711

inc (scan);

2712

end;

2713

ANYBUT:

2714

while (Result < TheMax) and

2715

(StrScan (opnd, scan^) = nil) do begin

2716

inc (Result);

2717

inc (scan);

2718

end;

2719

ANYOFCI:

2720

while (Result < TheMax) and (StrScanCI (opnd, scan^) <> nil) do begin

2721

inc (Result);

2722

inc (scan);

2723

end;

2724

ANYBUTCI:

2725

while (Result < TheMax) and (StrScanCI (opnd, scan^) = nil) do begin

2726

inc (Result);

2727

inc (scan);

2728

end;

2729

{$ENDIF}

2730

else begin // Oh dear. Called inappropriately.

2731

Result := 0; // Best compromise.

2732

Error (reeRegRepeatCalledInappropriately);

2733

EXIT;

2734

end;

2735

end; { of case}

2736

reginput := scan;

2737

end; { of function TRegExpr.regrepeat

2738

--------------------------------------------------------------}

2739

2740

function TRegExpr.regnext (p : PRegExprChar) : PRegExprChar;

2741

// dig the "next" pointer out of a node

2742

var offset : TRENextOff;

2743

begin

2744

if p = @regdummy then begin

2745

Result := nil;

2746

EXIT;

2747

end;

2748

offset := PRENextOff (p + REOpSz)^; //###0.933 inlined NEXT

2749

if offset = 0

2750

then Result := nil

2751

else Result := p + offset;

2752

end; { of function TRegExpr.regnext

2753

--------------------------------------------------------------}

2754

2755

function TRegExpr.MatchPrim (prog : PRegExprChar) : boolean;

2756

// recursively matching routine

2757

// Conceptually the strategy is simple: check to see whether the current

2758

// node matches, call self recursively to see whether the rest matches,

2759

// and then act accordingly. In practice we make some effort to avoid

2760

// recursion, in particular by going through "ordinary" nodes (that don't

2761

// need to know whether the rest of the match failed) by a loop instead of

2762

// by recursion.

2763

var

2764

scan : PRegExprChar; // Current node.

2765

next : PRegExprChar; // Next node.

2766

len : integer;

2767

opnd : PRegExprChar;

2768

no : integer;

2769

save : PRegExprChar;

2770

nextch : REChar;

2771

BracesMin, BracesMax : integer; // we use integer instead of TREBracesArg for better support */+

2772

{$IFDEF ComplexBraces}

2773

SavedLoopStack : array [1 .. LoopStackMax] of integer; // :(( very bad for recursion

2774

SavedLoopStackIdx : integer; //###0.925

2775

{$ENDIF}

2776

begin

2777

Result := false;

2778

scan := prog;

2779

2780

while scan <> nil do begin

2781

len := PRENextOff (scan + 1)^; //###0.932 inlined regnext

2782

if len = 0

2783

then next := nil

2784

else next := scan + len;

2785

2786

case scan^ of

2787

NOTBOUND, //###0.943 //!!! think about UseSetOfChar !!!

2788

BOUND:

2789

if (scan^ = BOUND)

2790

xor (

2791

((reginput = fInputStart) or (Pos ((reginput - 1)^, fWordChars) <= 0))

2792

and (reginput^ <> #0) and (Pos (reginput^, fWordChars) > 0)

2793

or

2794

(reginput <> fInputStart) and (Pos ((reginput - 1)^, fWordChars) > 0)

2795

and ((reginput^ = #0) or (Pos (reginput^, fWordChars) <= 0)))

2796

then EXIT;

2797

2798

BOL: if reginput <> fInputStart

2799

then EXIT;

2800

EOL: if reginput^ <> #0

2801

then EXIT;

2802

BOLML: if reginput > fInputStart then begin

2803

nextch := (reginput - 1)^;

2804

if (nextch <> fLinePairedSeparatorTail)

2805

or ((reginput - 1) <= fInputStart)

2806

or ((reginput - 2)^ <> fLinePairedSeparatorHead)

2807

then begin

2808

if (nextch = fLinePairedSeparatorHead)

2809

and (reginput^ = fLinePairedSeparatorTail)

2810

then EXIT; // don't stop between paired separator

2811

if

2812

{$IFNDEF UniCode}

2813

not (nextch in fLineSeparatorsSet)

2814

{$ELSE}

2815

(pos (nextch, fLineSeparators) <= 0)

2816

{$ENDIF}

2817

then EXIT;

2818

end;

2819

end;

2820

EOLML: if reginput^ <> #0 then begin

2821

nextch := reginput^;

2822

if (nextch <> fLinePairedSeparatorHead)

2823

or ((reginput + 1)^ <> fLinePairedSeparatorTail)

2824

then begin

2825

if (nextch = fLinePairedSeparatorTail)

2826

and (reginput > fInputStart)

2827

and ((reginput - 1)^ = fLinePairedSeparatorHead)

2828

then EXIT; // don't stop between paired separator

2829

if

2830

{$IFNDEF UniCode}

2831

not (nextch in fLineSeparatorsSet)

2832

{$ELSE}

2833

(pos (nextch, fLineSeparators) <= 0)

2834

{$ENDIF}

2835

then EXIT;

2836

end;

2837

end;

2838

ANY: begin

2839

if reginput^ = #0

2840

then EXIT;

2841

inc (reginput);

2842

end;

2843

ANYML: begin //###0.941

2844

if (reginput^ = #0)

2845

or ((reginput^ = fLinePairedSeparatorHead)

2846

and ((reginput + 1)^ = fLinePairedSeparatorTail))

2847

or {$IFNDEF UniCode} (reginput^ in fLineSeparatorsSet)

2848

{$ELSE} (pos (reginput^, fLineSeparators) > 0) {$ENDIF}

2849

then EXIT;

2850

inc (reginput);

2851

end;

2852

ANYDIGIT: begin

2853

if (reginput^ = #0) or (reginput^ < '0') or (reginput^ > '9')

2854

then EXIT;

2855

inc (reginput);

2856

end;

2857

NOTDIGIT: begin

2858

if (reginput^ = #0) or ((reginput^ >= '0') and (reginput^ <= '9'))

2859

then EXIT;

2860

inc (reginput);

2861

end;

2862

{$IFNDEF UseSetOfChar} //###0.929

2863

ANYLETTER: begin

2864

if (reginput^ = #0) or (Pos (reginput^, fWordChars) <= 0) //###0.943

2865

then EXIT;

2866

inc (reginput);

2867

end;

2868

NOTLETTER: begin

2869

if (reginput^ = #0) or (Pos (reginput^, fWordChars) > 0) //###0.943

2870

then EXIT;

2871

inc (reginput);

2872

end;

2873

ANYSPACE: begin

2874

if (reginput^ = #0) or not (Pos (reginput^, fSpaceChars) > 0) //###0.943

2875

then EXIT;

2876

inc (reginput);

2877

end;

2878

NOTSPACE: begin

2879

if (reginput^ = #0) or (Pos (reginput^, fSpaceChars) > 0) //###0.943

2880

then EXIT;

2881

inc (reginput);

2882

end;

2883

{$ENDIF}

2884

EXACTLYCI: begin

2885

opnd := scan + REOpSz + RENextOffSz; // OPERAND

2886

// Inline the first character, for speed.

2887

if (opnd^ <> reginput^)

2888

and (InvertCase (opnd^) <> reginput^)

2889

then EXIT;

2890

len := strlen (opnd);

2891

//###0.929 begin

2892

no := len;

2893

save := reginput;

2894

while no > 1 do begin

2895

inc (save);

2896

inc (opnd);

2897

if (opnd^ <> save^)

2898

and (InvertCase (opnd^) <> save^)

2899

then EXIT;

2900

dec (no);

2901

end;

2902

//###0.929 end

2903

inc (reginput, len);

2904

end;

2905

EXACTLY: begin

2906

opnd := scan + REOpSz + RENextOffSz; // OPERAND

2907

// Inline the first character, for speed.

2908

if opnd^ <> reginput^

2909

then EXIT;

2910

len := strlen (opnd);

2911

//###0.929 begin

2912

no := len;

2913

save := reginput;

2914

while no > 1 do begin

2915

inc (save);

2916

inc (opnd);

2917

if opnd^ <> save^

2918

then EXIT;

2919

dec (no);

2920

end;

2921

//###0.929 end

2922

inc (reginput, len);

2923

end;

2924

BSUBEXP: begin //###0.936

2925

no := ord ((scan + REOpSz + RENextOffSz)^);

2926

if startp [no] = nil

2927

then EXIT;

2928

if endp [no] = nil

2929

then EXIT;

2930

save := reginput;

2931

opnd := startp [no];

2932

while opnd < endp [no] do begin

2933

if (save >= fInputEnd) or (save^ <> opnd^)

2934

then EXIT;

2935

inc (save);

2936

inc (opnd);

2937

end;

2938

reginput := save;

2939

end;

2940

BSUBEXPCI: begin //###0.936

2941

no := ord ((scan + REOpSz + RENextOffSz)^);

2942

if startp [no] = nil

2943

then EXIT;

2944

if endp [no] = nil

2945

then EXIT;

2946

save := reginput;

2947

opnd := startp [no];

2948

while opnd < endp [no] do begin

2949

if (save >= fInputEnd) or

2950

((save^ <> opnd^) and (save^ <> InvertCase (opnd^)))

2951

then EXIT;

2952

inc (save);

2953

inc (opnd);

2954

end;

2955

reginput := save;

2956

end;

2957

ANYOFTINYSET: begin

2958

if (reginput^ = #0) or //!!!TinySet

2959

((reginput^ <> (scan + REOpSz + RENextOffSz)^)

2960

and (reginput^ <> (scan + REOpSz + RENextOffSz + 1)^)

2961

and (reginput^ <> (scan + REOpSz + RENextOffSz + 2)^))

2962

then EXIT;

2963

inc (reginput);

2964

end;

2965

ANYBUTTINYSET: begin

2966

if (reginput^ = #0) or //!!!TinySet

2967

(reginput^ = (scan + REOpSz + RENextOffSz)^)

2968

or (reginput^ = (scan + REOpSz + RENextOffSz + 1)^)

2969

or (reginput^ = (scan + REOpSz + RENextOffSz + 2)^)

2970

then EXIT;

2971

inc (reginput);

2972

end;

2973

{$IFDEF UseSetOfChar} //###0.929

2974

ANYOFFULLSET: begin

2975

if (reginput^ = #0)

2976

or not (reginput^ in PSetOfREChar (scan + REOpSz + RENextOffSz)^)

2977

then EXIT;

2978

inc (reginput);

2979

end;

2980

{$ELSE}

2981

ANYOF: begin

2982

if (reginput^ = #0) or (StrScan (scan + REOpSz + RENextOffSz, reginput^) = nil)

2983

then EXIT;

2984

inc (reginput);

2985

end;

2986

ANYBUT: begin

2987

if (reginput^ = #0) or (StrScan (scan + REOpSz + RENextOffSz, reginput^) <> nil)

2988

then EXIT;

2989

inc (reginput);

2990

end;

2991

ANYOFCI: begin

2992

if (reginput^ = #0) or (StrScanCI (scan + REOpSz + RENextOffSz, reginput^) = nil)

2993

then EXIT;

2994

inc (reginput);

2995

end;

2996

ANYBUTCI: begin

2997

if (reginput^ = #0) or (StrScanCI (scan + REOpSz + RENextOffSz, reginput^) <> nil)

2998

then EXIT;

2999

inc (reginput);

3000

end;

3001

{$ENDIF}

3002

NOTHING: ;

3003

COMMENT: ;

3004

BACK: ;

3005

Succ (OPEN) .. TREOp (Ord (OPEN) + NSUBEXP - 1) : begin //###0.929

3006

no := ord (scan^) - ord (OPEN);

3007

// save := reginput;

3008

save := startp [no]; //###0.936

3009

startp [no] := reginput; //###0.936

3010

Result := MatchPrim (next);

3011

if not Result //###0.936

3012

then startp [no] := save;

3013

// if Result and (startp [no] = nil)

3014

// then startp [no] := save;

3015

// Don't set startp if some later invocation of the same

3016

// parentheses already has.

3017

EXIT;

3018

end;

3019

Succ (CLOSE) .. TREOp (Ord (CLOSE) + NSUBEXP - 1): begin //###0.929

3020

no := ord (scan^) - ord (CLOSE);

3021

// save := reginput;

3022

save := endp [no]; //###0.936

3023

endp [no] := reginput; //###0.936

3024

Result := MatchPrim (next);

3025

if not Result //###0.936

3026

then endp [no] := save;

3027

// if Result and (endp [no] = nil)

3028

// then endp [no] := save;

3029

// Don't set endp if some later invocation of the same

3030

// parentheses already has.

3031

EXIT;

3032

end;

3033

BRANCH: begin

3034

if (next^ <> BRANCH) // No choice.

3035

then next := scan + REOpSz + RENextOffSz // Avoid recursion

3036

else begin

3037

REPEAT

3038

save := reginput;

3039

Result := MatchPrim (scan + REOpSz + RENextOffSz);

3040

if Result

3041

then EXIT;

3042

reginput := save;

3043

scan := regnext (scan);

3044

UNTIL (scan = nil) or (scan^ <> BRANCH);

3045

EXIT;

3046

end;

3047

end;

3048

{$IFDEF ComplexBraces}

3049

LOOPENTRY: begin //###0.925

3050

no := LoopStackIdx;

3051

inc (LoopStackIdx);

3052

if LoopStackIdx > LoopStackMax then begin

3053

Error (reeLoopStackExceeded);

3054

EXIT;

3055

end;

3056

save := reginput;

3057

LoopStack [LoopStackIdx] := 0; // init loop counter

3058

Result := MatchPrim (next); // execute LOOP

3059

LoopStackIdx := no; // cleanup

3060

if Result

3061

then EXIT;

3062

reginput := save;

3063

EXIT;

3064

end;

3065

LOOP, LOOPNG: begin //###0.940

3066

if LoopStackIdx <= 0 then begin

3067

Error (reeLoopWithoutEntry);

3068

EXIT;

3069

end;

3070

opnd := scan + PRENextOff (scan + REOpSz + RENextOffSz + 2 * REBracesArgSz)^;

3071

BracesMin := PREBracesArg (scan + REOpSz + RENextOffSz)^;

3072

BracesMax := PREBracesArg (scan + REOpSz + RENextOffSz + REBracesArgSz)^;

3073

save := reginput;

3074

if LoopStack [LoopStackIdx] >= BracesMin then begin // Min alredy matched - we can work

3075

if scan^ = LOOP then begin

3076

// greedy way - first try to max deep of greed ;)

3077

if LoopStack [LoopStackIdx] < BracesMax then begin

3078

inc (LoopStack [LoopStackIdx]);

3079

no := LoopStackIdx;

3080

Result := MatchPrim (opnd);

3081

LoopStackIdx := no;

3082

if Result

3083

then EXIT;

3084

reginput := save;

3085

end;

3086

dec (LoopStackIdx); // Fail. May be we are too greedy? ;)

3087

Result := MatchPrim (next);

3088

if not Result

3089

then reginput := save;

3090

EXIT;

3091

end

3092

else begin

3093

// non-greedy - try just now

3094

Result := MatchPrim (next);

3095

if Result

3096

then EXIT

3097

else reginput := save; // failed - move next and try again

3098

if LoopStack [LoopStackIdx] < BracesMax then begin

3099

inc (LoopStack [LoopStackIdx]);

3100

no := LoopStackIdx;

3101

Result := MatchPrim (opnd);

3102

LoopStackIdx := no;

3103

if Result

3104

then EXIT;

3105

reginput := save;

3106

end;

3107

dec (LoopStackIdx); // Failed - back up

3108

EXIT;

3109

end

3110

end

3111

else begin // first match a min_cnt times

3112

inc (LoopStack [LoopStackIdx]);

3113

no := LoopStackIdx;

3114

Result := MatchPrim (opnd);

3115

LoopStackIdx := no;

3116

if Result

3117

then EXIT;

3118

dec (LoopStack [LoopStackIdx]);

3119

reginput := save;

3120

EXIT;

3121

end;

3122

end;

3123

{$ENDIF}

3124

STAR, PLUS, BRACES, STARNG, PLUSNG, BRACESNG: begin

3125

// Lookahead to avoid useless match attempts when we know

3126

// what character comes next.

3127

nextch := #0;

3128

if next^ = EXACTLY

3129

then nextch := (next + REOpSz + RENextOffSz)^;

3130

BracesMax := MaxInt; // infinite loop for * and + //###0.92

3131

if (scan^ = STAR) or (scan^ = STARNG)

3132

then BracesMin := 0 // STAR

3133

else if (scan^ = PLUS) or (scan^ = PLUSNG)

3134

then BracesMin := 1 // PLUS

3135

else begin // BRACES

3136

BracesMin := PREBracesArg (scan + REOpSz + RENextOffSz)^;

3137

BracesMax := PREBracesArg (scan + REOpSz + RENextOffSz + REBracesArgSz)^;

3138

end;

3139

save := reginput;

3140

opnd := scan + REOpSz + RENextOffSz;

3141

if (scan^ = BRACES) or (scan^ = BRACESNG)

3142

then inc (opnd, 2 * REBracesArgSz);

3143

3144

if (scan^ = PLUSNG) or (scan^ = STARNG) or (scan^ = BRACESNG) then begin

3145

// non-greedy mode

3146

BracesMax := regrepeat (opnd, BracesMax); // don't repeat more than BracesMax

3147

// Now we know real Max limit to move forward (for recursion 'back up')

3148

// In some cases it can be faster to check only Min positions first,

3149

// but after that we have to check every position separtely instead

3150

// of fast scannig in loop.

3151

no := BracesMin;

3152

while no <= BracesMax do begin

3153

reginput := save + no;

3154

// If it could work, try it.

3155

if (nextch = #0) or (reginput^ = nextch) then begin

3156

{$IFDEF ComplexBraces}

3157

System.Move (LoopStack, SavedLoopStack, SizeOf (LoopStack)); //###0.925

3158

SavedLoopStackIdx := LoopStackIdx;

3159

{$ENDIF}

3160

if MatchPrim (next) then begin

3161

Result := true;

3162

EXIT;

3163

end;

3164

{$IFDEF ComplexBraces}

3165

System.Move (SavedLoopStack, LoopStack, SizeOf (LoopStack));

3166

LoopStackIdx := SavedLoopStackIdx;

3167

{$ENDIF}

3168

end;

3169

inc (no); // Couldn't or didn't - move forward.

3170

end; { of while}

3171

EXIT;

3172

end

3173

else begin // greedy mode

3174

no := regrepeat (opnd, BracesMax); // don't repeat more than max_cnt

3175

while no >= BracesMin do begin

3176

// If it could work, try it.

3177

if (nextch = #0) or (reginput^ = nextch) then begin

3178

{$IFDEF ComplexBraces}

3179

System.Move (LoopStack, SavedLoopStack, SizeOf (LoopStack)); //###0.925

3180

SavedLoopStackIdx := LoopStackIdx;

3181

{$ENDIF}

3182

if MatchPrim (next) then begin

3183

Result := true;

3184

EXIT;

3185

end;

3186

{$IFDEF ComplexBraces}

3187

System.Move (SavedLoopStack, LoopStack, SizeOf (LoopStack));

3188

LoopStackIdx := SavedLoopStackIdx;

3189

{$ENDIF}

3190

end;

3191

dec (no); // Couldn't or didn't - back up.

3192

reginput := save + no;

3193

end; { of while}

3194

EXIT;

3195

end;

3196

end;

3197

EEND: begin

3198

Result := true; // Success!

3199

EXIT;

3200

end;

3201

else begin

3202

Error (reeMatchPrimMemoryCorruption);

3203

EXIT;

3204

end;

3205

end; { of case scan^}

3206

scan := next;

3207

end; { of while scan <> nil}

3208

3209

// We get here only if there's trouble -- normally "case EEND" is the

3210

// terminating point.

3211

Error (reeMatchPrimCorruptedPointers);

3212

end; { of function TRegExpr.MatchPrim

3213

--------------------------------------------------------------}

3214

3215

{$IFDEF UseFirstCharSet} //###0.929

3216

procedure TRegExpr.FillFirstCharSet (prog : PRegExprChar);

3217

var

3218

scan : PRegExprChar; // Current node.

3219

next : PRegExprChar; // Next node.

3220

opnd : PRegExprChar;

3221

min_cnt : integer;

3222

begin

3223

scan := prog;

3224

while scan <> nil do begin

3225

next := regnext (scan);

3226

case PREOp (scan)^ of

3227

BSUBEXP, BSUBEXPCI: begin //###0.938

3228

FirstCharSet := [#0 .. #255]; // :((( we cannot

3229

// optimize r.e. if it starts with back reference

3230

EXIT;

3231

end;

3232

BOL, BOLML: ; // EXIT; //###0.937

3233

EOL, EOLML: begin //###0.948 was empty in 0.947, was EXIT in 0.937

3234

Include (FirstCharSet, #0);

3235

if ModifierM

3236

then begin

3237

opnd := PRegExprChar (LineSeparators);

3238

while opnd^ <> #0 do begin

3239

Include (FirstCharSet, opnd^);

3240

inc (opnd);

3241

end;

3242

end;

3243

EXIT;

3244

end;

3245

BOUND, NOTBOUND: ; //###0.943 ?!!

3246

ANY, ANYML: begin // we can better define ANYML !!!

3247

FirstCharSet := [#0 .. #255]; //###0.930

3248

EXIT;

3249

end;

3250

ANYDIGIT: begin

3251

FirstCharSet := FirstCharSet + ['0' .. '9'];

3252

EXIT;

3253

end;

3254

NOTDIGIT: begin

3255

FirstCharSet := FirstCharSet + ([#0 .. #255] - ['0' .. '9']); //###0.948 FirstCharSet was forgotten

3256

EXIT;

3257

end;

3258

EXACTLYCI: begin

3259

Include (FirstCharSet, (scan + REOpSz + RENextOffSz)^);

3260

Include (FirstCharSet, InvertCase ((scan + REOpSz + RENextOffSz)^));

3261

EXIT;

3262

end;

3263

EXACTLY: begin

3264

Include (FirstCharSet, (scan + REOpSz + RENextOffSz)^);

3265

EXIT;

3266

end;

3267

ANYOFFULLSET: begin

3268

FirstCharSet := FirstCharSet + PSetOfREChar (scan + REOpSz + RENextOffSz)^;

3269

EXIT;

3270

end;

3271

ANYOFTINYSET: begin

3272

//!!!TinySet

3273

Include (FirstCharSet, (scan + REOpSz + RENextOffSz)^);

3274

Include (FirstCharSet, (scan + REOpSz + RENextOffSz + 1)^);

3275

Include (FirstCharSet, (scan + REOpSz + RENextOffSz + 2)^);

3276

// ... // up to TinySetLen

3277

EXIT;

3278

end;

3279

ANYBUTTINYSET: begin

3280

//!!!TinySet

3281

FirstCharSet := FirstCharSet + ([#0 .. #255] - [ //###0.948 FirstCharSet was forgotten

3282

(scan + REOpSz + RENextOffSz)^,

3283

(scan + REOpSz + RENextOffSz + 1)^,

3284

(scan + REOpSz + RENextOffSz + 2)^]);

3285

// ... // up to TinySetLen

3286

EXIT;

3287

end;

3288

NOTHING: ;

3289

COMMENT: ;

3290

BACK: ;

3291

Succ (OPEN) .. TREOp (Ord (OPEN) + NSUBEXP - 1) : begin //###0.929

3292

FillFirstCharSet (next);

3293

EXIT;

3294

end;

3295

Succ (CLOSE) .. TREOp (Ord (CLOSE) + NSUBEXP - 1): begin //###0.929

3296

FillFirstCharSet (next);

3297

EXIT;

3298

end;

3299

BRANCH: begin

3300

if (PREOp (next)^ <> BRANCH) // No choice.

3301

then next := scan + REOpSz + RENextOffSz // Avoid recursion.

3302

else begin

3303

REPEAT

3304

FillFirstCharSet (scan + REOpSz + RENextOffSz);

3305

scan := regnext (scan);

3306

UNTIL (scan = nil) or (PREOp (scan)^ <> BRANCH);

3307

EXIT;

3308

end;

3309

end;

3310

{$IFDEF ComplexBraces}

3311

LOOPENTRY: begin //###0.925

3312

// LoopStack [LoopStackIdx] := 0; //###0.940 line removed

3313

FillFirstCharSet (next); // execute LOOP

3314

EXIT;

3315

end;

3316

LOOP, LOOPNG: begin //###0.940

3317

opnd := scan + PRENextOff (scan + REOpSz + RENextOffSz + REBracesArgSz * 2)^;

3318

min_cnt := PREBracesArg (scan + REOpSz + RENextOffSz)^;

3319

FillFirstCharSet (opnd);

3320

if min_cnt = 0

3321

then FillFirstCharSet (next);

3322

EXIT;

3323

end;

3324

{$ENDIF}

3325

STAR, STARNG: //###0.940

3326

FillFirstCharSet (scan + REOpSz + RENextOffSz);

3327

PLUS, PLUSNG: begin //###0.940

3328

FillFirstCharSet (scan + REOpSz + RENextOffSz);

3329

EXIT;

3330

end;

3331

BRACES, BRACESNG: begin //###0.940

3332

opnd := scan + REOpSz + RENextOffSz + REBracesArgSz * 2;

3333

min_cnt := PREBracesArg (scan + REOpSz + RENextOffSz)^; // BRACES

3334

FillFirstCharSet (opnd);

3335

if min_cnt > 0

3336

then EXIT;

3337

end;

3338

EEND: begin

3339

FirstCharSet := [#0 .. #255]; //###0.948

3340

EXIT;

3341

end;

3342

else begin

3343

Error (reeMatchPrimMemoryCorruption);

3344

EXIT;

3345

end;

3346

end; { of case scan^}

3347

scan := next;

3348

end; { of while scan <> nil}

3349

end; { of procedure FillFirstCharSet

3350

--------------------------------------------------------------}

3351

{$ENDIF}

3352

3353

function TRegExpr.Exec (const AInputString : RegExprString) : boolean;

3354

begin

3355

InputString := AInputString;

3356

Result := ExecPrim (1);

3357

end; { of function TRegExpr.Exec

3358

--------------------------------------------------------------}

3359

3360

{$IFDEF OverMeth}

3361

{$IFNDEF FPC}

3362

function TRegExpr.Exec : boolean;

3363

begin

3364

Result := ExecPrim (1);

3365

end; { of function TRegExpr.Exec

3366

--------------------------------------------------------------}

3367

{$ENDIF}

3368

function TRegExpr.Exec (AOffset: integer) : boolean;

3369

begin

3370

Result := ExecPrim (AOffset);

3371

end; { of function TRegExpr.Exec

3372

--------------------------------------------------------------}

3373

{$ENDIF}

3374

3375

function TRegExpr.ExecPos (AOffset: integer {$IFDEF DefParam}= 1{$ENDIF}) : boolean;

3376

begin

3377

Result := ExecPrim (AOffset);

3378

end; { of function TRegExpr.ExecPos

3379

--------------------------------------------------------------}

3380

3381

function TRegExpr.ExecPrim (AOffset: integer) : boolean;

3382

procedure ClearMatchs;

3383

// Clears matchs array

3384

var i : integer;

3385

begin

3386

for i := 0 to NSUBEXP - 1 do begin

3387

startp [i] := nil;

3388

endp [i] := nil;

3389

end;

3390

end; { of procedure ClearMatchs;

3391

..............................................................}

3392

function RegMatch (str : PRegExprChar) : boolean;

3393

// try match at specific point

3394

begin

3395

//###0.949 removed clearing of start\endp

3396

reginput := str;

3397

Result := MatchPrim (programm + REOpSz);

3398

if Result then begin

3399

startp [0] := str;

3400

endp [0] := reginput;

3401

end;

3402

end; { of function RegMatch

3403

..............................................................}

3404

var

3405

s : PRegExprChar;

3406

StartPtr: PRegExprChar;

3407

InputLen : integer;

3408

begin

3409

Result := false; // Be paranoid...

3410

3411

ClearMatchs; //###0.949

3412

// ensure that Match cleared either if optimization tricks or some error

3413

// will lead to leaving ExecPrim without actual search. That is

3414

// importent for ExecNext logic and so on.

3415

3416

if not IsProgrammOk //###0.929

3417

then EXIT;

3418

3419

// Check InputString presence

3420

if not Assigned (fInputString) then begin

3421

Error (reeNoInpitStringSpecified);

3422

EXIT;

3423

end;

3424

3425

InputLen := length (fInputString);

3426

3427

//Check that the start position is not negative

3428

if AOffset < 1 then begin

3429

Error (reeOffsetMustBeGreaterThen0);

3430

EXIT;

3431

end;

3432

// Check that the start position is not longer than the line

3433

// If so then exit with nothing found

3434

if AOffset > (InputLen + 1) // for matching empty string after last char.

3435

then EXIT;

3436

3437

StartPtr := fInputString + AOffset - 1;

3438

3439

// If there is a "must appear" string, look for it.

3440

if regmust <> nil then begin

3441

s := StartPtr;

3442

REPEAT

3443

s := StrScan (s, regmust [0]);

3444

if s <> nil then begin

3445

if StrLComp (s, regmust, regmlen) = 0

3446

then BREAK; // Found it.

3447

inc (s);

3448

end;

3449

UNTIL s = nil;

3450

if s = nil // Not present.

3451

then EXIT;

3452

end;

3453

3454

// Mark beginning of line for ^ .

3455

fInputStart := fInputString;

3456

3457

// Pointer to end of input stream - for

3458

// pascal-style string processing (may include #0)

3459

fInputEnd := fInputString + InputLen;

3460

3461

{$IFDEF ComplexBraces}

3462

// no loops started

3463

LoopStackIdx := 0; //###0.925

3464

{$ENDIF}

3465

3466

// Simplest case: anchored match need be tried only once.

3467

if reganch <> #0 then begin

3468

Result := RegMatch (StartPtr);

3469

EXIT;

3470

end;

3471

3472

// Messy cases: unanchored match.

3473

s := StartPtr;

3474

if regstart <> #0 then // We know what char it must start with.

3475

REPEAT

3476

s := StrScan (s, regstart);

3477

if s <> nil then begin

3478

Result := RegMatch (s);

3479

if Result

3480

then EXIT

3481

else ClearMatchs; //###0.949

3482

inc (s);

3483

end;

3484

UNTIL s = nil

3485

else begin // We don't - general case.

3486

repeat //###0.948

3487

{$IFDEF UseFirstCharSet}

3488

if s^ in FirstCharSet

3489

then Result := RegMatch (s);

3490

{$ELSE}

3491

Result := RegMatch (s);

3492

{$ENDIF}

3493

if Result or (s^ = #0) // Exit on a match or after testing the end-of-string.

3494

then EXIT

3495

else ClearMatchs; //###0.949

3496

inc (s);

3497

until false;

3498

(* optimized and fixed by Martin Fuller - empty strings

3499

were not allowed to pass thru in UseFirstCharSet mode

3500

{$IFDEF UseFirstCharSet} //###0.929

3501

while s^ <> #0 do begin

3502

if s^ in FirstCharSet

3503

then Result := RegMatch (s);

3504

if Result

3505

then EXIT;

3506

inc (s);

3507

end;

3508

{$ELSE}

3509

REPEAT

3510

Result := RegMatch (s);

3511

if Result

3512

then EXIT;

3513

inc (s);

3514

UNTIL s^ = #0;

3515

{$ENDIF}

3516

*)

3517

end;

3518

// Failure

3519

end; { of function TRegExpr.ExecPrim

3520

--------------------------------------------------------------}

3521

3522

function TRegExpr.ExecNext : boolean;

3523

var offset : integer;

3524

begin

3525

Result := false;

3526

if not Assigned (startp[0]) or not Assigned (endp[0]) then begin

3527

Error (reeExecNextWithoutExec);

3528

EXIT;

3529

end;

3530

// Offset := MatchPos [0] + MatchLen [0];

3531

// if MatchLen [0] = 0

3532

Offset := endp [0] - fInputString + 1; //###0.929

3533

if endp [0] = startp [0] //###0.929

3534

then inc (Offset); // prevent infinite looping if empty string match r.e.

3535

Result := ExecPrim (Offset);

3536

end; { of function TRegExpr.ExecNext

3537

--------------------------------------------------------------}

3538

3539

function TRegExpr.GetInputString : RegExprString;

3540

begin

3541

if not Assigned (fInputString) then begin

3542

Error (reeGetInputStringWithoutInputString);

3543

EXIT;

3544

end;

3545

Result := fInputString;

3546

end; { of function TRegExpr.GetInputString

3547

--------------------------------------------------------------}

3548

3549

procedure TRegExpr.SetInputString (const AInputString : RegExprString);

3550

var

3551

Len : integer;

3552

i : integer;

3553

begin

3554

// clear Match* - before next Exec* call it's undefined

3555

for i := 0 to NSUBEXP - 1 do begin

3556

startp [i] := nil;

3557

endp [i] := nil;

3558

end;

3559

3560

// need reallocation of input string buffer ?

3561

Len := length (AInputString);

3562

if Assigned (fInputString) and (Length (fInputString) <> Len) then begin

3563

FreeMem (fInputString);

3564

fInputString := nil;

3565

end;

3566

// buffer [re]allocation

3567

if not Assigned (fInputString)

3568

then GetMem (fInputString, (Len + 1) * SizeOf (REChar));

3569

3570

// copy input string into buffer

3571

{$IFDEF UniCode}

3572

StrPCopy (fInputString, Copy (AInputString, 1, Len)); //###0.927

3573

{$ELSE}

3574

StrLCopy (fInputString, PRegExprChar (AInputString), Len);

3575

{$ENDIF}

3576

3577

{

3578

fInputString : string;

3579

fInputStart, fInputEnd : PRegExprChar;

3580

3581

SetInputString:

3582

fInputString := AInputString;

3583

UniqueString (fInputString);

3584

fInputStart := PChar (fInputString);

3585

Len := length (fInputString);

3586

fInputEnd := PRegExprChar (integer (fInputStart) + Len); ??

3587

!! startp/endp �� ?

3588

}

3589

end; { of procedure TRegExpr.SetInputString

3590

--------------------------------------------------------------}

3591

3592

procedure TRegExpr.SetLineSeparators (const AStr : RegExprString);

3593

begin

3594

if AStr <> fLineSeparators then begin

3595

fLineSeparators := AStr;

3596

InvalidateProgramm;

3597

end;

3598

end; { of procedure TRegExpr.SetLineSeparators

3599

--------------------------------------------------------------}

3600

3601

procedure TRegExpr.SetLinePairedSeparator (const AStr : RegExprString);

3602

begin

3603

if length (AStr) = 2 then begin

3604

if AStr [1] = AStr [2] then begin

3605

// it's impossible for our 'one-point' checking to support

3606

// two chars separator for identical chars

3607

Error (reeBadLinePairedSeparator);

3608

EXIT;

3609

end;

3610

if not fLinePairedSeparatorAssigned

3611

or (AStr [1] <> fLinePairedSeparatorHead)

3612

or (AStr [2] <> fLinePairedSeparatorTail) then begin

3613

fLinePairedSeparatorAssigned := true;

3614

fLinePairedSeparatorHead := AStr [1];

3615

fLinePairedSeparatorTail := AStr [2];

3616

InvalidateProgramm;

3617

end;

3618

end

3619

else if length (AStr) = 0 then begin

3620

if fLinePairedSeparatorAssigned then begin

3621

fLinePairedSeparatorAssigned := false;

3622

InvalidateProgramm;

3623

end;

3624

end

3625

else Error (reeBadLinePairedSeparator);

3626

end; { of procedure TRegExpr.SetLinePairedSeparator

3627

--------------------------------------------------------------}

3628

3629

function TRegExpr.GetLinePairedSeparator : RegExprString;

3630

begin

3631

if fLinePairedSeparatorAssigned then begin

3632

{$IFDEF UniCode}

3633

// Here is some UniCode 'magic'

3634

// If You do know better decision to concatenate

3635

// two WideChars, please, let me know!

3636

Result := fLinePairedSeparatorHead; //###0.947

3637

Result := Result + fLinePairedSeparatorTail;

3638

{$ELSE}

3639

Result := fLinePairedSeparatorHead + fLinePairedSeparatorTail;

3640

{$ENDIF}

3641

end

3642

else Result := '';

3643

end; { of function TRegExpr.GetLinePairedSeparator

3644

--------------------------------------------------------------}

3645

3646

function TRegExpr.Substitute (const ATemplate : RegExprString) : RegExprString;

3647

// perform substitutions after a regexp match

3648

// completely rewritten in 0.929

3649

var

3650

TemplateLen : integer;

3651

TemplateBeg, TemplateEnd : PRegExprChar;

3652

p, p0, ResultPtr : PRegExprChar;

3653

ResultLen : integer;

3654

n : integer;

3655

Ch : REChar;

3656

function ParseVarName (var APtr : PRegExprChar) : integer;

3657

// extract name of variable (digits, may be enclosed with

3658

// curly braces) from APtr^, uses TemplateEnd !!!

3659

const

3660

Digits = ['0' .. '9'];

3661

var

3662

p : PRegExprChar;

3663

Delimited : boolean;

3664

begin

3665

Result := 0;

3666

p := APtr;

3667

Delimited := (p < TemplateEnd) and (p^ = '{');

3668

if Delimited

3669

then inc (p); // skip left curly brace

3670

if (p < TemplateEnd) and (p^ = '&')

3671

then inc (p) // this is '$&' or '${&}'

3672

else

3673

while (p < TemplateEnd) and

3674

{$IFDEF UniCode} //###0.935

3675

(ord (p^) < 256) and (char (p^) in Digits)

3676

{$ELSE}

3677

(p^ in Digits)

3678

{$ENDIF}

3679

do begin

3680

Result := Result * 10 + (ord (p^) - ord ('0')); //###0.939

3681

inc (p);

3682

end;

3683

if Delimited then

3684

if (p < TemplateEnd) and (p^ = '}')

3685

then inc (p) // skip right curly brace

3686

else p := APtr; // isn't properly terminated

3687

if p = APtr

3688

then Result := -1; // no valid digits found or no right curly brace

3689

APtr := p;

3690

end;

3691

begin

3692

// Check programm and input string

3693

if not IsProgrammOk

3694

then EXIT;

3695

if not Assigned (fInputString) then begin

3696

Error (reeNoInpitStringSpecified);

3697

EXIT;

3698

end;

3699

// Prepare for working

3700

TemplateLen := length (ATemplate);

3701

if TemplateLen = 0 then begin // prevent nil pointers

3702

Result := '';

3703

EXIT;

3704

end;

3705

TemplateBeg := pointer (ATemplate);

3706

TemplateEnd := TemplateBeg + TemplateLen;

3707

// Count result length for speed optimization.

3708

ResultLen := 0;

3709

p := TemplateBeg;

3710

while p < TemplateEnd do begin

3711

Ch := p^;

3712

inc (p);

3713

if Ch = '$'

3714

then n := ParseVarName (p)

3715

else n := -1;

3716

if n >= 0 then begin

3717

if (n < NSUBEXP) and Assigned (startp [n]) and Assigned (endp [n])

3718

then inc (ResultLen, endp [n] - startp [n]);

3719

end

3720

else begin

3721

if (Ch = EscChar) and (p < TemplateEnd)

3722

then inc (p); // quoted or special char followed

3723

inc (ResultLen);

3724

end;

3725

end;

3726

// Get memory. We do it once and it significant speed up work !

3727

if ResultLen = 0 then begin

3728

Result := '';

3729

EXIT;

3730

end;

3731

SetString (Result, nil, ResultLen);

3732

// Fill Result

3733

ResultPtr := pointer (Result);

3734

p := TemplateBeg;

3735

while p < TemplateEnd do begin

3736

Ch := p^;

3737

inc (p);

3738

if Ch = '$'

3739

then n := ParseVarName (p)

3740

else n := -1;

3741

if n >= 0 then begin

3742

p0 := startp [n];

3743

if (n < NSUBEXP) and Assigned (p0) and Assigned (endp [n]) then

3744

while p0 < endp [n] do begin

3745

ResultPtr^ := p0^;

3746

inc (ResultPtr);

3747

inc (p0);

3748

end;

3749

end

3750

else begin

3751

if (Ch = EscChar) and (p < TemplateEnd) then begin // quoted or special char followed

3752

Ch := p^;

3753

inc (p);

3754

end;

3755

ResultPtr^ := Ch;

3756

inc (ResultPtr);

3757

end;

3758

end;

3759

end; { of function TRegExpr.Substitute

3760

--------------------------------------------------------------}

3761

3762

procedure TRegExpr.Split (AInputStr : RegExprString; APieces : TStrings);

3763

var PrevPos : integer;

3764

begin

3765

PrevPos := 1;

3766

if Exec (AInputStr) then

3767

REPEAT

3768

APieces.Add (System.Copy (AInputStr, PrevPos, MatchPos [0] - PrevPos));

3769

PrevPos := MatchPos [0] + MatchLen [0];

3770

UNTIL not ExecNext;

3771

APieces.Add (System.Copy (AInputStr, PrevPos, MaxInt)); // Tail

3772

end; { of procedure TRegExpr.Split

3773

--------------------------------------------------------------}

3774

3775

function TRegExpr.Replace (AInputStr : RegExprString; const AReplaceStr : RegExprString;

3776

AUseSubstitution : boolean{$IFDEF DefParam}= False{$ENDIF}) : RegExprString;

3777

var

3778

PrevPos : integer;

3779

begin

3780

Result := '';

3781

PrevPos := 1;

3782

if Exec (AInputStr) then

3783

REPEAT

3784

Result := Result + System.Copy (AInputStr, PrevPos,

3785

MatchPos [0] - PrevPos);

3786

if AUseSubstitution //###0.946

3787

then Result := Result + Substitute (AReplaceStr)

3788

else Result := Result + AReplaceStr;

3789

PrevPos := MatchPos [0] + MatchLen [0];

3790

UNTIL not ExecNext;

3791

Result := Result + System.Copy (AInputStr, PrevPos, MaxInt); // Tail

3792

end; { of function TRegExpr.Replace

3793

--------------------------------------------------------------}

3794

3795

function TRegExpr.ReplaceEx (AInputStr : RegExprString;

3796

AReplaceFunc : TRegExprReplaceFunction)

3797

: RegExprString;

3798

var

3799

PrevPos : integer;

3800

begin

3801

Result := '';

3802

PrevPos := 1;

3803

if Exec (AInputStr) then

3804

REPEAT

3805

Result := Result + System.Copy (AInputStr, PrevPos,

3806

MatchPos [0] - PrevPos)

3807

+ AReplaceFunc (Self);

3808

PrevPos := MatchPos [0] + MatchLen [0];

3809

UNTIL not ExecNext;

3810

Result := Result + System.Copy (AInputStr, PrevPos, MaxInt); // Tail

3811

end; { of function TRegExpr.ReplaceEx

3812

--------------------------------------------------------------}

3813

3814

3815

{$IFDEF OverMeth}

3816

function TRegExpr.Replace (AInputStr : RegExprString;

3817

AReplaceFunc : TRegExprReplaceFunction)

3818

: RegExprString;

3819

begin

3820

ReplaceEx (AInputStr, AReplaceFunc);

3821

end; { of function TRegExpr.Replace

3822

--------------------------------------------------------------}

3823

{$ENDIF}

3824

3825

{=============================================================}

3826

{====================== Debug section ========================}

3827

{=============================================================}

3828

3829

{$IFDEF RegExpPCodeDump}

3830

function TRegExpr.DumpOp (op : TREOp) : RegExprString;

3831

// printable representation of opcode

3832

begin

3833

case op of

3834

BOL: Result := 'BOL';

3835

EOL: Result := 'EOL';

3836

BOLML: Result := 'BOLML';

3837

EOLML: Result := 'EOLML';

3838

BOUND: Result := 'BOUND'; //###0.943

3839

NOTBOUND: Result := 'NOTBOUND'; //###0.943

3840

ANY: Result := 'ANY';

3841

ANYML: Result := 'ANYML'; //###0.941

3842

ANYLETTER: Result := 'ANYLETTER';

3843

NOTLETTER: Result := 'NOTLETTER';

3844

ANYDIGIT: Result := 'ANYDIGIT';

3845

NOTDIGIT: Result := 'NOTDIGIT';

3846

ANYSPACE: Result := 'ANYSPACE';

3847

NOTSPACE: Result := 'NOTSPACE';

3848

ANYOF: Result := 'ANYOF';

3849

ANYBUT: Result := 'ANYBUT';

3850

ANYOFCI: Result := 'ANYOF/CI';

3851

ANYBUTCI: Result := 'ANYBUT/CI';

3852

BRANCH: Result := 'BRANCH';

3853

EXACTLY: Result := 'EXACTLY';

3854

EXACTLYCI: Result := 'EXACTLY/CI';

3855

NOTHING: Result := 'NOTHING';

3856

COMMENT: Result := 'COMMENT';

3857

BACK: Result := 'BACK';

3858

EEND: Result := 'END';

3859

BSUBEXP: Result := 'BSUBEXP';

3860

BSUBEXPCI: Result := 'BSUBEXP/CI';

3861

Succ (OPEN) .. TREOp (Ord (OPEN) + NSUBEXP - 1): //###0.929

3862

Result := Format ('OPEN[%d]', [ord (op) - ord (OPEN)]);

3863

Succ (CLOSE) .. TREOp (Ord (CLOSE) + NSUBEXP - 1): //###0.929

3864

Result := Format ('CLOSE[%d]', [ord (op) - ord (CLOSE)]);

3865

STAR: Result := 'STAR';

3866

PLUS: Result := 'PLUS';

3867

BRACES: Result := 'BRACES';

3868

{$IFDEF ComplexBraces}

3869

LOOPENTRY: Result := 'LOOPENTRY'; //###0.925

3870

LOOP: Result := 'LOOP'; //###0.925

3871

LOOPNG: Result := 'LOOPNG'; //###0.940

3872

{$ENDIF}

3873

ANYOFTINYSET: Result:= 'ANYOFTINYSET';

3874

ANYBUTTINYSET:Result:= 'ANYBUTTINYSET';

3875

{$IFDEF UseSetOfChar} //###0.929

3876

ANYOFFULLSET: Result:= 'ANYOFFULLSET';

3877

{$ENDIF}

3878

STARNG: Result := 'STARNG'; //###0.940

3879

PLUSNG: Result := 'PLUSNG'; //###0.940

3880

BRACESNG: Result := 'BRACESNG'; //###0.940

3881

else Error (reeDumpCorruptedOpcode);

3882

end; {of case op}

3883

Result := ':' + Result;

3884

end; { of function TRegExpr.DumpOp

3885

--------------------------------------------------------------}

3886

3887

function TRegExpr.Dump : RegExprString;

3888

// dump a regexp in vaguely comprehensible form

3889

var

3890

s : PRegExprChar;

3891

op : TREOp; // Arbitrary non-END op.

3892

next : PRegExprChar;

3893

i : integer;

3894

Diff : integer;

3895

{$IFDEF UseSetOfChar} //###0.929

3896

Ch : REChar;

3897

{$ENDIF}

3898

begin

3899

if not IsProgrammOk //###0.929

3900

then EXIT;

3901

3902

op := EXACTLY;

3903

Result := '';

3904

s := programm + REOpSz;

3905

while op <> EEND do begin // While that wasn't END last time...

3906

op := s^;

3907

Result := Result + Format ('%2d%s', [s - programm, DumpOp (s^)]); // Where, what.

3908

next := regnext (s);

3909

if next = nil // Next ptr.

3910

then Result := Result + ' (0)'

3911

else begin

3912

if next > s //###0.948 PWideChar subtraction workaround (see comments in Tail method for details)

3913

then Diff := next - s

3914

else Diff := - (s - next);

3915

Result := Result + Format (' (%d) ', [(s - programm) + Diff]);

3916

end;

3917

inc (s, REOpSz + RENextOffSz);

3918

if (op = ANYOF) or (op = ANYOFCI) or (op = ANYBUT) or (op = ANYBUTCI)

3919

or (op = EXACTLY) or (op = EXACTLYCI) then begin

3920

// Literal string, where present.

3921

while s^ <> #0 do begin

3922

Result := Result + s^;

3923

inc (s);

3924

end;

3925

inc (s);

3926

end;

3927

if (op = ANYOFTINYSET) or (op = ANYBUTTINYSET) then begin

3928

for i := 1 to TinySetLen do begin

3929

Result := Result + s^;

3930

inc (s);

3931

end;

3932

end;

3933

if (op = BSUBEXP) or (op = BSUBEXPCI) then begin

3934

Result := Result + ' \' + IntToStr (Ord (s^));

3935

inc (s);

3936

end;

3937

{$IFDEF UseSetOfChar} //###0.929

3938

if op = ANYOFFULLSET then begin

3939

for Ch := #0 to #255 do

3940

if Ch in PSetOfREChar (s)^ then

3941

if Ch < ' '

3942

then Result := Result + '#' + IntToStr (Ord (Ch)) //###0.936

3943

else Result := Result + Ch;

3944

inc (s, SizeOf (TSetOfREChar));

3945

end;

3946

{$ENDIF}

3947

if (op = BRACES) or (op = BRACESNG) then begin //###0.941

3948

// show min/max argument of BRACES operator

3949

Result := Result + Format ('{%d,%d}', [PREBracesArg (s)^, PREBracesArg (s + REBracesArgSz)^]);

3950

inc (s, REBracesArgSz * 2);

3951

end;

3952

{$IFDEF ComplexBraces}

3953

if (op = LOOP) or (op = LOOPNG) then begin //###0.940

3954

Result := Result + Format (' -> (%d) {%d,%d}', [

3955

(s - programm - (REOpSz + RENextOffSz)) + PRENextOff (s + 2 * REBracesArgSz)^,

3956

PREBracesArg (s)^, PREBracesArg (s + REBracesArgSz)^]);

3957

inc (s, 2 * REBracesArgSz + RENextOffSz);

3958

end;

3959

{$ENDIF}

3960

Result := Result + #$d#$a;

3961

end; { of while}

3962

3963

// Header fields of interest.

3964

3965

if regstart <> #0

3966

then Result := Result + 'start ' + regstart;

3967

if reganch <> #0

3968

then Result := Result + 'anchored ';

3969

if regmust <> nil

3970

then Result := Result + 'must have ' + regmust;

3971

{$IFDEF UseFirstCharSet} //###0.929

3972

Result := Result + #$d#$a'FirstCharSet:';

3973

for Ch := #0 to #255 do

3974

if Ch in FirstCharSet

3975

then begin

3976

if Ch < ' '

3977

then Result := Result + '#' + IntToStr(Ord(Ch)) //###0.948

3978

else Result := Result + Ch;

3979

end;

3980

{$ENDIF}

3981

Result := Result + #$d#$a;

3982

end; { of function TRegExpr.Dump

3983

--------------------------------------------------------------}

3984

{$ENDIF}

3985

3986

{$IFDEF reRealExceptionAddr}

3987

{$OPTIMIZATION ON}

3988

// ReturnAddr works correctly only if compiler optimization is ON

3989

// I placed this method at very end of unit because there are no

3990

// way to restore compiler optimization flag ...

3991

{$ENDIF}

3992

procedure TRegExpr.Error (AErrorID : integer);

3993

{$IFDEF reRealExceptionAddr}

3994

function ReturnAddr : pointer; //###0.938

3995

asm

3996

mov eax,[ebp+4]

3997

end;

3998

{$ENDIF}

3999

var

4000

e : ERegExpr;

4001

begin

4002

fLastError := AErrorID; // dummy stub - useless because will raise exception

4003

if AErrorID < 1000 // compilation error ?

4004

then e := ERegExpr.Create (ErrorMsg (AErrorID) // yes - show error pos

4005

+ ' (pos ' + IntToStr (CompilerErrorPos) + ')')

4006

else e := ERegExpr.Create (ErrorMsg (AErrorID));

4007

e.ErrorCode := AErrorID;

4008

e.CompilerErrorPos := CompilerErrorPos;

4009

raise e

4010

{$IFDEF reRealExceptionAddr}

4011

At ReturnAddr; //###0.938

4012

{$ENDIF}

4013

end; { of procedure TRegExpr.Error

4014

--------------------------------------------------------------}

4015

4016

(*

4017

PCode persistence:

4018

FirstCharSet

4019

programm, regsize

4020

regstart // -> programm

4021

reganch // -> programm

4022

regmust, regmlen // -> programm

4023

fExprIsCompiled

4024

*)

4025

4026

// be carefull - placed here code will be always compiled with

4027

// compiler optimization flag

4028

4029

{$IFDEF FPC}

4030

initialization

4031

RegExprInvertCaseFunction := TRegExpr.InvertCaseFunction;

4032

4033

{$ENDIF}

4034

end.

4035