testsqlscript.pas 23 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682683684685686687688689690691692693694695696697698699700701702703704705706707708709710711712713714715716717718719720721722723724725726727728729730731732733734735736737738739740741742743744745746747748749750751752753754755756757758759760761762763764765766767768769770771772773774775776777778779780781782783784785786787788789790791792793794795796797798799800801802803804805806807808809810811812813814815816817818819820821822823824825826827828829830831832833834835836837838839840841842843844845846847848849850851852853854855856857858859860861862863864865866867868869870871872873874875876877878879880881882883884885886887888889890891892893894895896897898899900901902903904905906907908909910911912913914915916917918919920
  1. {
  2. This file is part of the Free Pascal run time library.
  3. Copyright (c) 2008 by the Free Pascal development team
  4. FPCUnit SQLScript test.
  5. See the file COPYING.FPC, included in this distribution,
  6. for details about the copyright.
  7. This program is distributed in the hope that it will be useful,
  8. but WITHOUT ANY WARRANTY; without even the implied warranty of
  9. MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
  10. **********************************************************************}
  11. unit testsqlscript;
  12. {$mode objfpc}{$H+}
  13. interface
  14. uses
  15. Classes, SysUtils, testregistry, sqlscript, fpcunit;
  16. type
  17. { TMyScript }
  18. TMyScript = class (TCustomSQLScript)
  19. private
  20. FExcept: string;
  21. FStatements : TStrings;
  22. FDirectives : TStrings;
  23. FCommits : integer;
  24. protected
  25. procedure ExecuteStatement (SQLStatement: TStrings; var StopExecution: Boolean); override;
  26. procedure ExecuteDirective (Directive, Argument: String; var StopExecution: Boolean); override;
  27. procedure ExecuteCommit(CommitRetaining: boolean=true); override;
  28. procedure DefaultDirectives; override;
  29. public
  30. constructor create (AnOwner: TComponent); override;
  31. destructor destroy; override;
  32. function StatementsExecuted : string;
  33. function DirectivesExecuted : string;
  34. property DoException : string read FExcept write FExcept;
  35. property Aborted;
  36. property Line;
  37. property UseDollarString;
  38. property dollarstrings;
  39. property Directives;
  40. property Defines;
  41. property Script;
  42. property Terminator;
  43. property CommentsinSQL;
  44. property UseSetTerm;
  45. property UseCommit;
  46. property UseDefines;
  47. property OnException;
  48. end;
  49. { TTestSQLScript }
  50. TTestSQLScript = class (TTestCase)
  51. private
  52. Script : TMyScript;
  53. exceptionstatement,
  54. exceptionmessage : string;
  55. UseContinue : boolean;
  56. procedure Add (s :string);
  57. procedure AssertStatDir (Statements, Directives : string);
  58. procedure DoExecution;
  59. procedure ExceptionHandler(Sender: TObject; Statement: TStrings; TheException: Exception; var Continue: boolean);
  60. procedure TestDirectiveOnException3;
  61. protected
  62. procedure SetUp; override;
  63. procedure TearDown; override;
  64. published
  65. procedure TestCreateDefaults;
  66. procedure TestTerminator;
  67. procedure TestTerminatorNoFinal;
  68. procedure TestSetTerm;
  69. procedure TestUseSetTerm;
  70. procedure TestComments;
  71. procedure TestUseComments;
  72. procedure TestCommit;
  73. procedure TestUseCommit;
  74. procedure TestDefine;
  75. procedure TestUndefine;
  76. procedure TestUndef;
  77. procedure TestIfdef1;
  78. procedure TestIfdef2;
  79. procedure TestIfndef1;
  80. procedure TestIfndef2;
  81. procedure TestElse1;
  82. procedure TestElse2;
  83. procedure TestEndif1;
  84. procedure TestEndif2;
  85. procedure TestUseDefines;
  86. procedure TestTermInComment;
  87. procedure TestTermInQuotes1;
  88. procedure TestTermInQuotes2;
  89. procedure TestCommentInComment;
  90. procedure TestCommentInQuotes1;
  91. procedure TestCommentInQuotes2;
  92. Procedure TestDashDashComment;
  93. procedure TestQuote1InComment;
  94. procedure TestQuote2InComment;
  95. procedure TestQuoteInQuotes1;
  96. procedure TestQuoteInQuotes2;
  97. procedure TestStatementStop;
  98. procedure TestDirectiveStop;
  99. procedure TestStatementExeception;
  100. procedure TestDirectiveException;
  101. procedure TestCommitException;
  102. procedure TestStatementOnExeception1;
  103. procedure TestStatementOnExeception2;
  104. procedure TestDirectiveOnException1;
  105. procedure TestDirectiveOnException2;
  106. procedure TestCommitOnException1;
  107. procedure TestCommitOnException2;
  108. procedure TestUseDollarSign;
  109. procedure TestUseDollarSign2;
  110. procedure TestUseDollarSign3;
  111. end;
  112. { TTestEventSQLScript }
  113. TTestEventSQLScript = class (TTestCase)
  114. private
  115. Script : TEventSQLScript;
  116. StopToSend : boolean;
  117. Received : string;
  118. notifycount : integer;
  119. LastSender : TObject;
  120. procedure Notify (Sender : TObject);
  121. procedure NotifyStatement (Sender: TObject; SQL_Statement: TStrings; var StopExecution: Boolean);
  122. procedure NotifyDirective (Sender: TObject; Directive, Argument: AnsiString; var StopExecution: Boolean);
  123. protected
  124. procedure SetUp; override;
  125. procedure TearDown; override;
  126. published
  127. procedure TestStatement;
  128. procedure TestStatementStop;
  129. procedure TestDirective;
  130. procedure TestDirectiveStop;
  131. procedure TestCommit;
  132. procedure TestBeforeExec;
  133. procedure TestAfterExec;
  134. end;
  135. implementation
  136. { TMyScript }
  137. procedure TMyScript.ExecuteStatement(SQLStatement: TStrings; var StopExecution: Boolean);
  138. var s : string;
  139. r : integer;
  140. begin
  141. if (SQLStatement.count = 1) and (compareText(SQLStatement[0],'END')=0) then
  142. StopExecution := true;
  143. s := '';
  144. for r := 0 to SQLstatement.count-1 do
  145. begin
  146. if s <> '' then
  147. s := s + ' ';
  148. s := s + SQLStatement[r];
  149. end;
  150. FStatements.Add (s);
  151. if DoException <> '' then
  152. raise exception.create(DoException);
  153. end;
  154. procedure TMyScript.ExecuteDirective(Directive, Argument: String; var StopExecution: Boolean);
  155. begin
  156. if Directive = 'STOP' then
  157. StopExecution := true;
  158. if Argument = '' then
  159. FDirectives.Add (Directive)
  160. else
  161. FDirectives.Add (format('%s(%s)', [Directive, Argument]));
  162. if DoException <> '' then
  163. raise exception.create(DoException);
  164. end;
  165. procedure TMyScript.ExecuteCommit(CommitRetaining: boolean=true);
  166. begin
  167. inc (FCommits);
  168. if DoException <> '' then
  169. raise exception.create(DoException);
  170. end;
  171. procedure TMyScript.DefaultDirectives;
  172. begin
  173. inherited DefaultDirectives;
  174. directives.add ('STOP');
  175. end;
  176. constructor TMyScript.create (AnOwner: TComponent);
  177. begin
  178. inherited create (AnOwner);
  179. FStatements := TStringlist.Create;
  180. FDirectives := TStringlist.Create;
  181. FCommits := 0;
  182. DoException := '';
  183. end;
  184. destructor TMyScript.destroy;
  185. begin
  186. FStatements.Free;
  187. FDirectives.Free;
  188. inherited destroy;
  189. end;
  190. function TMyScript.StatementsExecuted: string;
  191. begin
  192. result := FStatements.Commatext;
  193. end;
  194. function TMyScript.DirectivesExecuted: string;
  195. begin
  196. result := FDirectives.Commatext;
  197. end;
  198. { TTestSQLScript }
  199. procedure TTestSQLScript.Add(s: string);
  200. begin
  201. Script.Script.Add (s);
  202. end;
  203. procedure TTestSQLScript.AssertStatDir(Statements, Directives: string);
  204. begin
  205. AssertEquals ('Executed Statements', Statements, script.StatementsExecuted);
  206. AssertEquals ('Executed Directives', Directives, script.DirectivesExecuted);
  207. end;
  208. procedure TTestSQLScript.DoExecution;
  209. begin
  210. script.execute;
  211. end;
  212. procedure TTestSQLScript.ExceptionHandler(Sender: TObject; Statement: TStrings;
  213. TheException: Exception; var Continue: boolean);
  214. var r : integer;
  215. s : string;
  216. begin
  217. Continue := UseContinue;
  218. if Statement.count > 0 then
  219. s := Statement[0];
  220. for r := 1 to Statement.count-1 do
  221. s := s + ',' + Statement[r];
  222. exceptionstatement := s;
  223. exceptionmessage := TheException.message;
  224. end;
  225. procedure TTestSQLScript.SetUp;
  226. begin
  227. inherited SetUp;
  228. Script := TMyscript.Create (nil);
  229. end;
  230. procedure TTestSQLScript.TearDown;
  231. begin
  232. Script.Free;
  233. inherited TearDown;
  234. end;
  235. procedure TTestSQLScript.TestCreateDefaults;
  236. begin
  237. with Script do
  238. begin
  239. AssertEquals ('Terminator', ';', Terminator);
  240. AssertTrue ('UseCommit', UseCommit);
  241. AssertTrue ('UseSetTerm', UseSetTerm);
  242. AssertTrue ('UseDefines', UseDefines);
  243. AssertTrue ('CommentsInSQL', CommentsInSQL);
  244. AssertFalse ('Aborted', Aborted);
  245. AssertEquals ('Line', 0, Line);
  246. AssertEquals ('Defines', 0, Defines.count);
  247. AssertEquals ('Directives', 12, Directives.count);
  248. AssertTrue('Have SET TERM',Directives.IndexOf('SET TERM')<>-1);
  249. AssertTrue('Have COMMIT WORK',Directives.IndexOf('COMMIT WORK')<>-1);
  250. AssertTrue('Have COMMIT RETAIN',Directives.IndexOf('COMMIT RETAIN')<>-1);
  251. AssertTrue('Have COMMIT',Directives.IndexOf('COMMIT')<>-1);
  252. AssertTrue('Have #IFDEF',Directives.IndexOf('#IFDEF')<>-1);
  253. AssertTrue('Have #IFNDEF',Directives.IndexOf('#IFNDEF')<>-1);
  254. AssertTrue('Have #ELSE',Directives.IndexOf('#ELSE')<>-1);
  255. AssertTrue('Have #ENDIF',Directives.IndexOf('#ENDIF')<>-1);
  256. AssertTrue('Have #DEFINE',Directives.IndexOf('#DEFINE')<>-1);
  257. AssertTrue('Have #UNDEF',Directives.IndexOf('#UNDEF')<>-1);
  258. AssertTrue('Have #UNDEFINE',Directives.IndexOf('#UNDEFINE')<>-1);
  259. // This is defined in our test class.
  260. AssertTrue('Have STOP',Directives.IndexOf('STOP')<>-1);
  261. end;
  262. end;
  263. procedure TTestSQLScript.TestTerminator;
  264. begin
  265. script.terminator := '!';
  266. Add('doe!iets!');
  267. Add('anders!');
  268. script.execute;
  269. AssertStatDir('doe,iets,anders', '');
  270. end;
  271. procedure TTestSQLScript.TestTerminatorNoFinal;
  272. begin
  273. script.terminator := '!';
  274. Add('doe!iets!');
  275. Add('anders');
  276. script.execute;
  277. AssertStatDir('doe,iets,anders', '');
  278. end;
  279. procedure TTestSQLScript.TestSetTerm;
  280. begin
  281. script.UseSetTerm:=true;
  282. Add('SET TERM !;');
  283. script.execute;
  284. AssertEquals ('terminator', '!', script.terminator);
  285. AssertStatDir('', '');
  286. end;
  287. procedure TTestSQLScript.TestUseSetTerm;
  288. begin
  289. script.UseSetTerm:=false;
  290. Script.Directives.Add ('SET TERM');
  291. Add('SET TERM !;');
  292. script.execute;
  293. AssertEquals ('terminator', ';', script.terminator);
  294. AssertStatDir('', '"SET TERM(!)"');
  295. end;
  296. procedure TTestSQLScript.TestComments;
  297. begin
  298. script.CommentsInSQL := true;
  299. Add('/* comment */');
  300. Add('statement;');
  301. script.execute;
  302. AssertStatDir ('"/* comment */ statement"', '');
  303. end;
  304. procedure TTestSQLScript.TestUseComments;
  305. begin
  306. script.CommentsInSQL := false;
  307. Add('/* comment */');
  308. Add('statement;');
  309. script.execute;
  310. AssertStatDir ('statement', '');
  311. end;
  312. procedure TTestSQLScript.TestCommit;
  313. begin
  314. script.UseCommit := true;
  315. Add('commit;');
  316. script.execute;
  317. AssertEquals ('Commits', 1, script.FCommits);
  318. AssertStatDir ('', '');
  319. end;
  320. procedure TTestSQLScript.TestUseCommit;
  321. begin
  322. script.UseCommit := false;
  323. with script.Directives do
  324. Delete(IndexOf('COMMIT'));
  325. Add('commit;');
  326. script.execute;
  327. AssertEquals ('Commits', 0, script.FCommits);
  328. AssertStatDir ('commit', '');
  329. end;
  330. procedure TTestSQLScript.TestDefine;
  331. begin
  332. script.UseDefines := true;
  333. Add ('#define iets;');
  334. script.execute;
  335. AssertStatDir ('', '');
  336. AssertEquals ('Aantal defines', 1, script.defines.count);
  337. AssertEquals ('Juiste define', 'iets', script.Defines[0]);
  338. end;
  339. procedure TTestSQLScript.TestUndefine;
  340. begin
  341. script.UseDefines := true;
  342. script.defines.Add ('iets');
  343. Add ('#undefine iets;');
  344. script.execute;
  345. AssertStatDir ('', '');
  346. AssertEquals ('Aantal defines', 0, script.defines.count);
  347. end;
  348. procedure TTestSQLScript.TestUndef;
  349. begin
  350. script.UseDefines := true;
  351. script.defines.Add ('iets');
  352. Add ('#Undef iets;');
  353. script.execute;
  354. AssertStatDir ('', '');
  355. AssertEquals ('Aantal defines', 0, script.defines.count);
  356. end;
  357. procedure TTestSQLScript.TestIfdef1;
  358. begin
  359. script.UseDefines := true;
  360. script.defines.add ('iets');
  361. Add('#ifdef iets;');
  362. Add('doe iets;');
  363. script.execute;
  364. AssertStatDir('"doe iets"', '');
  365. end;
  366. procedure TTestSQLScript.TestIfdef2;
  367. begin
  368. script.UseDefines := true;
  369. Add('#ifdef iets;');
  370. Add('doe iets;');
  371. script.execute;
  372. AssertStatDir('', '');
  373. end;
  374. procedure TTestSQLScript.TestIfndef1;
  375. begin
  376. script.UseDefines := true;
  377. Add('#ifndef iets;');
  378. Add('doe iets;');
  379. script.execute;
  380. AssertStatDir('"doe iets"', '');
  381. end;
  382. procedure TTestSQLScript.TestIfndef2;
  383. begin
  384. script.UseDefines := true;
  385. script.defines.add ('iets');
  386. Add('#ifndef iets;');
  387. Add('doe iets;');
  388. script.execute;
  389. AssertStatDir('', '');
  390. end;
  391. procedure TTestSQLScript.TestElse1;
  392. begin
  393. script.UseDefines := true;
  394. script.defines.add ('iets');
  395. Add('#ifdef iets;');
  396. Add('doe iets;');
  397. add('#else;');
  398. add('anders;');
  399. script.execute;
  400. AssertStatDir('"doe iets"', '');
  401. end;
  402. procedure TTestSQLScript.TestElse2;
  403. begin
  404. script.UseDefines := true;
  405. script.defines.add ('iets');
  406. Add('#ifndef iets;');
  407. Add('doe iets;');
  408. add('#else;');
  409. add('anders;');
  410. script.execute;
  411. AssertStatDir('anders', '');
  412. end;
  413. procedure TTestSQLScript.TestEndif1;
  414. begin
  415. script.UseDefines := true;
  416. Add('#ifdef iets;');
  417. Add('doe iets;');
  418. add('#endif;');
  419. add('anders;');
  420. script.execute;
  421. AssertStatDir('anders', '');
  422. end;
  423. procedure TTestSQLScript.TestEndif2;
  424. begin
  425. script.UseDefines := true;
  426. Add('#ifndef iets;');
  427. Add('doe iets;');
  428. add('#endif;');
  429. add('anders;');
  430. script.execute;
  431. AssertStatDir('"doe iets",anders', '');
  432. end;
  433. procedure TTestSQLScript.TestUseDefines;
  434. begin
  435. script.UseDefines := false;
  436. Add('#ifndef iets;');
  437. Add('doe iets;');
  438. add('#endif;');
  439. add('anders;');
  440. script.execute;
  441. AssertStatDir('"doe iets",anders', '#IFNDEF(iets),#ENDIF');
  442. end;
  443. procedure TTestSQLScript.TestTermInComment;
  444. begin
  445. script.CommentsInSQL := false;
  446. Add('/* terminator ; */iets;');
  447. script.execute;
  448. AssertStatDir('iets', '');
  449. end;
  450. procedure TTestSQLScript.TestTermInQuotes1;
  451. begin
  452. script.CommentsInSQL := false;
  453. Add('iets '';'';');
  454. script.execute;
  455. AssertStatDir('"iets '';''"', '');
  456. end;
  457. procedure TTestSQLScript.TestTermInQuotes2;
  458. begin
  459. script.CommentsInSQL := false;
  460. Add('iets ";";');
  461. script.execute;
  462. AssertStatDir('"iets "";"""', '');
  463. end;
  464. procedure TTestSQLScript.TestCommentInComment;
  465. begin
  466. script.CommentsInSQL := false;
  467. Add('/* meer /* */iets;');
  468. script.execute;
  469. AssertStatDir('iets', '');
  470. end;
  471. procedure TTestSQLScript.TestCommentInQuotes1;
  472. begin
  473. script.CommentsInSQL := false;
  474. Add('iets ''/* meer */'';');
  475. script.execute;
  476. AssertStatDir('"iets ''/* meer */''"', '');
  477. end;
  478. procedure TTestSQLScript.TestCommentInQuotes2;
  479. begin
  480. script.CommentsInSQL := false;
  481. Add('iets "/* meer */";');
  482. script.execute;
  483. AssertStatDir('"iets ""/* meer */"""', '');
  484. end;
  485. procedure TTestSQLScript.TestDashDashComment;
  486. begin
  487. script.CommentsInSQL := false;
  488. Add('-- my comment');
  489. Add('CREATE TABLE "tPatients" (');
  490. Add(' "BloodGroup" character(2),');
  491. Add(' CONSTRAINT "ck_tPatients_BloodGroup" CHECK (("BloodGroup" = ANY (ARRAY[''A''::bpchar, ''B''::bpchar, ''AB''::bpchar, ''0''::bpchar]))),');
  492. Add(');');
  493. script.execute;
  494. AssertStatDir('"CREATE TABLE ""tPatients"" ( ""BloodGroup"" character(2), CONSTRAINT ""ck_tPatients_BloodGroup"" CHECK ((""BloodGroup"" = ANY (ARRAY[''A''::bpchar, ''B''::bpchar, ''AB''::bpchar, ''0''::bpchar]))), )"', '');
  495. end;
  496. procedure TTestSQLScript.TestQuote1InComment;
  497. begin
  498. script.CommentsInSQL := false;
  499. Add('/* s''morgens */iets;');
  500. script.execute;
  501. AssertStatDir('iets', '');
  502. end;
  503. procedure TTestSQLScript.TestQuote2InComment;
  504. begin
  505. script.CommentsInSQL := false;
  506. Add('/* s"morgens */iets;');
  507. script.execute;
  508. AssertStatDir('iets', '');
  509. end;
  510. procedure TTestSQLScript.TestQuoteInQuotes1;
  511. begin
  512. script.CommentsInSQL := false;
  513. Add('iets ''s"morgens'';');
  514. script.execute;
  515. AssertStatDir('"iets ''s""morgens''"', '');
  516. end;
  517. procedure TTestSQLScript.TestQuoteInQuotes2;
  518. begin
  519. script.CommentsInSQL := false;
  520. Add('iets "s''morgens";');
  521. script.execute;
  522. AssertStatDir('"iets ""s''morgens"""', '');
  523. end;
  524. procedure TTestSQLScript.TestStatementStop;
  525. begin
  526. Add('END;meer;');
  527. script.execute;
  528. AssertStatDir('END', '');
  529. end;
  530. procedure TTestSQLScript.TestDirectiveStop;
  531. begin
  532. Add('Stop;meer;');
  533. script.execute;
  534. AssertStatDir('', 'STOP');
  535. end;
  536. procedure TTestSQLScript.TestStatementExeception;
  537. begin
  538. Add('iets;');
  539. script.DoException:='FOUT';
  540. AssertException (exception, @DoExecution);
  541. AssertStatDir('iets', '');
  542. end;
  543. procedure TTestSQLScript.TestDirectiveException;
  544. begin
  545. Add('iets;');
  546. script.Directives.Add('IETS');
  547. script.DoException := 'FOUT';
  548. AssertException (exception, @DoExecution);
  549. AssertStatDir('', 'IETS');
  550. end;
  551. procedure TTestSQLScript.TestCommitException;
  552. begin
  553. Add ('commit;');
  554. script.DoException := 'FOUT';
  555. AssertException (exception, @DoExecution);
  556. AssertStatDir('', '');
  557. AssertEquals ('Commit count', 1, Script.FCommits);
  558. end;
  559. procedure TTestSQLScript.TestStatementOnExeception1;
  560. begin
  561. UseContinue := true;
  562. script.DoException := 'Fout';
  563. Add ('foutief;');
  564. script.OnException:=@ExceptionHandler;
  565. Script.Execute;
  566. AssertEquals ('exception message', 'Fout', exceptionmessage);
  567. AssertEquals ('exception statement', 'foutief', exceptionstatement);
  568. end;
  569. procedure TTestSQLScript.TestStatementOnExeception2;
  570. begin
  571. UseContinue := false;
  572. script.DoException := 'Fout';
  573. Add ('foutief;');
  574. script.OnException:=@ExceptionHandler;
  575. AssertException (exception, @DoExecution);
  576. AssertEquals ('exception message', 'Fout', exceptionmessage);
  577. AssertEquals ('exception statement', 'foutief', exceptionstatement);
  578. end;
  579. procedure TTestSQLScript.TestDirectiveOnException1;
  580. begin
  581. UseContinue := true;
  582. script.DoException := 'Fout';
  583. Add ('foutief;');
  584. Script.Directives.Add ('FOUTIEF');
  585. script.OnException:=@ExceptionHandler;
  586. Script.Execute;
  587. AssertEquals ('exception message', 'Fout', exceptionmessage);
  588. AssertEquals ('exception statement', 'FOUTIEF', exceptionstatement);
  589. end;
  590. procedure TTestSQLScript.TestDirectiveOnException2;
  591. begin
  592. UseContinue := False;
  593. script.DoException := 'Fout';
  594. Add ('foutief;');
  595. Script.Directives.Add ('FOUTIEF');
  596. script.OnException:=@ExceptionHandler;
  597. AssertException (exception, @DoExecution);
  598. AssertEquals ('exception message', 'Fout', exceptionmessage);
  599. AssertEquals ('exception statement', 'FOUTIEF', exceptionstatement);
  600. end;
  601. procedure TTestSQLScript.TestDirectiveOnException3;
  602. begin
  603. UseContinue := true;
  604. script.DoException := 'Fout';
  605. Add ('foutief probleem;');
  606. Script.Directives.Add ('FOUTIEF');
  607. script.OnException:=@ExceptionHandler;
  608. Script.Execute;
  609. AssertEquals ('exception message', 'Fout', exceptionmessage);
  610. AssertEquals ('exception statement', 'FOUTIEF,probleem', exceptionstatement);
  611. end;
  612. procedure TTestSQLScript.TestCommitOnException1;
  613. begin
  614. UseContinue := true;
  615. script.DoException := 'Fout';
  616. Add ('Commit;');
  617. script.OnException:=@ExceptionHandler;
  618. Script.Execute;
  619. AssertEquals ('exception message', 'Fout', exceptionmessage);
  620. AssertEquals ('exception statement', 'COMMIT', exceptionstatement);
  621. AssertEquals ('commit count', 1, Script.FCommits);
  622. end;
  623. procedure TTestSQLScript.TestCommitOnException2;
  624. begin
  625. UseContinue := false;
  626. script.DoException := 'Fout';
  627. Add ('Commit;');
  628. script.OnException:=@ExceptionHandler;
  629. AssertException (exception, @DoExecution);
  630. AssertEquals ('exception message', 'Fout', exceptionmessage);
  631. AssertEquals ('exception statement', 'COMMIT', exceptionstatement);
  632. AssertEquals ('commit count', 1, Script.FCommits);
  633. end;
  634. Const
  635. PLSQL1 = 'CREATE or replace FUNCTION test_double_bad_sum ( value1 int, value2 int ) '+
  636. 'RETURNS int AS $$ '+
  637. 'DECLARE '+
  638. ' TheDoubleSum int; '+
  639. 'BEGIN '+
  640. ' -- Start '+
  641. ' TheDoubleSum := value1; '+
  642. ' /* sum '+
  643. ' number '+
  644. ' 1 */ '+
  645. ' TheDoubleSum := TheDoubleSum + value2; '+
  646. ' TheDoubleSum := TheDoubleSum + value2; -- Sum number 2 '+
  647. ' return TheDoubleSum; '+
  648. 'END; '+
  649. '$$ '+
  650. 'LANGUAGE plpgsql';
  651. PLSQL2 = 'COMMENT ON FUNCTION test_double_bad_sum(IN integer, IN integer) '+
  652. ' IS ''Just a '+
  653. ' test function '+
  654. ' !!!''';
  655. PLSQL3 = 'CREATE or replace FUNCTION test_double_bad_sum ( value1 int, value2 int ) '+
  656. 'RETURNS int AS $BOB$ '+
  657. 'DECLARE '+
  658. ' TheDoubleSum int; '+
  659. 'BEGIN '+
  660. ' -- Start '+
  661. ' TheDoubleSum := value1; '+
  662. ' /* sum '+
  663. ' number '+
  664. ' 1 */ '+
  665. ' TheDoubleSum := TheDoubleSum + value2; '+
  666. ' TheDoubleSum := TheDoubleSum + value2; -- Sum number 2 '+
  667. ' return TheDoubleSum; '+
  668. 'END; '+
  669. '$BOB$ '+
  670. 'LANGUAGE plpgsql';
  671. procedure TTestSQLScript.TestUseDollarSign;
  672. begin
  673. script.UseDollarString:=True;
  674. Add(PLSQL1+';');
  675. script.execute;
  676. // Double quotes because there are spaces.
  677. AssertStatDir('"'+plsql1+'"', '');
  678. end;
  679. procedure TTestSQLScript.TestUseDollarSign2;
  680. begin
  681. script.UseDollarString:=True;
  682. Add(PLSQL1+';');
  683. Add(PLSQL2+';');
  684. script.execute;
  685. // Double quotes because there are spaces.
  686. AssertStatDir('"'+plsql1+'","'+PLSQL2+'"', '');
  687. end;
  688. procedure TTestSQLScript.TestUseDollarSign3;
  689. begin
  690. script.UseDollarString:=True;
  691. script.DollarStrings.Add('BOB');
  692. Add(PLSQL3+';');
  693. script.execute;
  694. // Double quotes because there are spaces.
  695. AssertStatDir('"'+plsql3+'"', '');
  696. end;
  697. { TTestEventSQLScript }
  698. procedure TTestEventSQLScript.Notify(Sender: TObject);
  699. begin
  700. inc (NotifyCount);
  701. LastSender := Sender;
  702. end;
  703. procedure TTestEventSQLScript.NotifyStatement(Sender: TObject;
  704. SQL_Statement: TStrings; var StopExecution: Boolean);
  705. var r : integer;
  706. s : string;
  707. begin
  708. StopExecution := StopToSend;
  709. if SQL_Statement.count > 0 then
  710. begin
  711. s := SQL_Statement[0];
  712. for r := 1 to SQL_Statement.count-1 do
  713. s := s + ';' + SQL_Statement[r];
  714. if SQL_Statement.count > 1 then
  715. s := '"' + s + '"';
  716. end
  717. else
  718. s := '';
  719. if received <> '' then
  720. received := received + ';' + s
  721. else
  722. received := s;
  723. LastSender := Sender;
  724. end;
  725. procedure TTestEventSQLScript.NotifyDirective(Sender: TObject; Directive,
  726. Argument: AnsiString; var StopExecution: Boolean);
  727. var s : string;
  728. begin
  729. StopExecution := StopToSend;
  730. if Argument = '' then
  731. s := Directive
  732. else
  733. s := format ('%s(%s)', [Directive, Argument]);
  734. if received <> '' then
  735. received := received + ';' + s
  736. else
  737. received := s;
  738. LastSender := Sender;
  739. end;
  740. procedure TTestEventSQLScript.SetUp;
  741. begin
  742. inherited SetUp;
  743. Script := TEventSQLScript.Create (nil);
  744. notifycount := 0;
  745. Received := '';
  746. LastSender := nil;
  747. end;
  748. procedure TTestEventSQLScript.TearDown;
  749. begin
  750. Script.Free;
  751. inherited TearDown;
  752. end;
  753. procedure TTestEventSQLScript.TestStatement;
  754. begin
  755. StopToSend:=false;
  756. Script.OnSQLStatement := @NotifyStatement;
  757. Script.Script.Text := 'stat1;stat2;';
  758. script.execute;
  759. AssertEquals ('Received', 'stat1;stat2', received);
  760. AssertSame ('Sender', script, LastSender);
  761. end;
  762. procedure TTestEventSQLScript.TestStatementStop;
  763. begin
  764. StopToSend:=true;
  765. Script.OnSQLStatement := @NotifyStatement;
  766. Script.Script.Text := 'stat1;stat2;';
  767. script.execute;
  768. AssertEquals ('Received', 'stat1', received);
  769. AssertSame ('Sender', script, LastSender);
  770. end;
  771. procedure TTestEventSQLScript.TestDirective;
  772. begin
  773. StopToSend:=false;
  774. Script.OnSQLStatement := @NotifyStatement;
  775. Script.OnDirective := @NotifyDirective;
  776. script.Directives.Add ('STAT1');
  777. Script.Script.Text := 'stat1 ik;stat2;';
  778. script.execute;
  779. AssertEquals ('Received', 'STAT1(ik);stat2', received);
  780. AssertSame ('Sender', script, LastSender);
  781. end;
  782. procedure TTestEventSQLScript.TestDirectiveStop;
  783. begin
  784. StopToSend:=true;
  785. Script.OnSQLStatement := @NotifyStatement;
  786. Script.OnDirective := @NotifyDirective;
  787. script.Directives.Add ('STAT1');
  788. Script.Script.Text := 'stat1 ik;stat2;';
  789. script.execute;
  790. AssertEquals ('Received', 'STAT1(ik)', received);
  791. AssertSame ('Sender', script, LastSender);
  792. end;
  793. procedure TTestEventSQLScript.TestCommit;
  794. begin
  795. Script.OnCommit := @Notify;
  796. Script.Script.Text := 'iets; commit; anders;';
  797. script.execute;
  798. AssertEquals ('NotifyCount', 1, NotifyCount);
  799. AssertSame ('Sender', script, LastSender);
  800. end;
  801. procedure TTestEventSQLScript.TestBeforeExec;
  802. begin
  803. Script.BeforeExecute := @Notify;
  804. Script.Script.Text := 'update iets; anders iets;';
  805. script.execute;
  806. AssertEquals ('NotifyCount', 1, NotifyCount);
  807. AssertSame ('Sender', script, LastSender);
  808. end;
  809. procedure TTestEventSQLScript.TestAfterExec;
  810. begin
  811. Script.AfterExecute := @Notify;
  812. Script.Script.Text := 'update iets; anders iets; en meer;';
  813. script.execute;
  814. AssertEquals ('NotifyCount', 1, NotifyCount);
  815. AssertSame ('Sender', script, LastSender);
  816. end;
  817. initialization
  818. RegisterTests ([TTestSQLScript, TTestEventSQLScript]);
  819. end.