summaryrefslogtreecommitdiff
path: root/t/11-ledgersmb.t
blob: 1b4181643da5f9071e1f2cb26dd9725500759091 (plain)
  1. #!/usr/bin/perl
  2. use strict;
  3. use warnings;
  4. $ENV{TMPDIR} = 't/var';
  5. use Test::More 'no_plan';
  6. use Test::Exception;
  7. use Test::Trap qw(trap $trap);
  8. use Math::BigFloat;
  9. use LedgerSMB::Sysconfig;
  10. use LedgerSMB;
  11. sub redirect {
  12. print "redirected\n";
  13. }
  14. sub lsmb_error_func {
  15. print $_[0];
  16. }
  17. ##line subroutine
  18. ##108 new
  19. ##235 redirect
  20. ##254 format_amount
  21. ##364 parse_amount
  22. ##408 round_amount
  23. ##423 call_procedure
  24. ##454 date_to_number
  25. ##490 db_init
  26. ##522 redo_rows
  27. ##547 merge
  28. my $lsmb = new LedgerSMB;
  29. my %myconfig;
  30. my $utfstr;
  31. my @r;
  32. ok(defined $lsmb);
  33. isa_ok($lsmb, 'LedgerSMB');
  34. # $lsmb->escape checks
  35. $lsmb = new LedgerSMB;
  36. $utfstr = "\xd8\xad";
  37. utf8::decode($utfstr);
  38. ok(!$lsmb->escape, 'escape: (undef)');
  39. ok(!$lsmb->escape('foo' => 'bar'), 'escape: (invalid args)');
  40. cmp_ok($lsmb->escape('string' => ' '), 'eq', '%20',
  41. 'escape: \' \'');
  42. cmp_ok($lsmb->escape('string' => 'foo'), 'eq', 'foo',
  43. 'escape: foo');
  44. cmp_ok($lsmb->escape('string' => 'foo bar'), 'eq', 'foo%20bar',
  45. 'escape: foo bar');
  46. TODO: {
  47. local $TODO = 'Fun with Unicode';
  48. cmp_ok($lsmb->escape('string' => $utfstr), 'eq', '%d8%ad',
  49. 'escape: U+D8AD');
  50. }
  51. # $lsmb->is_blank checks
  52. $lsmb = new LedgerSMB;
  53. $lsmb->{blank} = ' ';
  54. $lsmb->{notblank} = ' d ';
  55. TODO: {
  56. local $TODO = 'Errors should be thrown';
  57. throws_ok{$lsmb->is_blank} 'Error::Simple', 'is_blank: (undef)';
  58. throws_ok{$lsmb->is_blank('foo' => 'bar')} 'Error::Simple',
  59. 'is_blank: (invalid args)';
  60. }
  61. is($lsmb->is_blank('name' => 'notblank'), 0, 'is_blank: notblank');
  62. is($lsmb->is_blank('name' => 'blank'), 1, 'is_blank: blank');
  63. # $lsmb->is_run_mode checks
  64. $lsmb = new LedgerSMB;
  65. $ENV{GATEWAY_INTERFACE} = 'foo';
  66. is($lsmb->is_run_mode('cgi'), 1, 'is_run_mode: CGI - CGI');
  67. is($lsmb->is_run_mode('cli'), 0, 'is_run_mode: CGI - CLI');
  68. is($lsmb->is_run_mode('mod_perl'), 0, 'is_run_mode: CGI - mod_perl');
  69. is($lsmb->is_run_mode('foo'), 0, 'is_run_mode: CGI - (bad mode)');
  70. is($lsmb->is_run_mode, 0, 'is_run_mode: CGI - (unknown mode)');
  71. $ENV{MOD_PERL} = 'foo';
  72. is($lsmb->is_run_mode('cgi'), 1, 'is_run_mode: CGI/mod_perl - CGI');
  73. is($lsmb->is_run_mode('cli'), 0, 'is_run_mode: CGI/mod_perl - CLI');
  74. is($lsmb->is_run_mode('mod_perl'), 1, 'is_run_mode: CGI/mod_perl - mod_perl');
  75. is($lsmb->is_run_mode('foo'), 0, 'is_run_mode: CGI/mod_perl - (bad mode)');
  76. is($lsmb->is_run_mode, 0, 'is_run_mode: CGI/mod_perl - (unknown mode)');
  77. delete $ENV{GATEWAY_INTERFACE};
  78. is($lsmb->is_run_mode('cgi'), 0, 'is_run_mode: mod_perl - CGI');
  79. is($lsmb->is_run_mode('cli'), 0, 'is_run_mode: mod_perl - CLI');
  80. is($lsmb->is_run_mode('mod_perl'), 1, 'is_run_mode: mod_perl - mod_perl');
  81. is($lsmb->is_run_mode('foo'), 0, 'is_run_mode: mod_perl - (bad mode)');
  82. is($lsmb->is_run_mode, 0, 'is_run_mode: mod_perl - (unknown mode)');
  83. delete $ENV{MOD_PERL};
  84. is($lsmb->is_run_mode('cgi'), 0, 'is_run_mode: CLI - CGI');
  85. is($lsmb->is_run_mode('cli'), 1, 'is_run_mode: CLI - CLI');
  86. is($lsmb->is_run_mode('mod_perl'), 0, 'is_run_mode: CLI - mod_perl');
  87. is($lsmb->is_run_mode('foo'), 0, 'is_run_mode: CLI - (bad mode)');
  88. is($lsmb->is_run_mode, 0, 'is_run_mode: CLI - (unknown mode)');
  89. # $lsmb->num_text_rows checks
  90. $lsmb = new LedgerSMB;
  91. is($lsmb->num_text_rows('string' => "apple\npear", 'cols' => 10, 'max' => 5),
  92. 2, 'num_text_rows: 2 rows, no column breakage, max 5 rows');
  93. is($lsmb->num_text_rows('string' => "apple\npear", 'cols' => 10, 'max' => 1),
  94. 1, 'num_text_rows: 2 rows, no column breakage, max 1 row');
  95. is($lsmb->num_text_rows('string' => "apple\npear", 'cols' => 10, 'max' => 2),
  96. 2, 'num_text_rows: 2 rows, no column breakage, max 2 rows');
  97. is($lsmb->num_text_rows('string' => "apple\npear", 'cols' => 10),
  98. 2, 'num_text_rows: 2 rows, no column breakage, no max row count');
  99. is($lsmb->num_text_rows('string' => "01234567890123456789", 'cols' => 10),
  100. 2, 'num_text_rows: 2 rows, non-word column breakage, no max row count');
  101. is($lsmb->num_text_rows('string' => "012345 67890123 456789", 'cols' => 10),
  102. 3, 'num_text_rows: 3 rows, word column breakage, no max row count');
  103. is($lsmb->num_text_rows('string' => "0123456789", 'cols' => 10),
  104. 1, 'num_text_rows: 1 rows, no breakage, max cols, no max row count');
  105. is($lsmb->num_text_rows('string' => "01234567890", 'cols' => 10),
  106. 2, 'num_text_rows: 2 rows, no breakage, max cols+1, no max row count');
  107. is($lsmb->num_text_rows('string' => "1\n\n2", 'cols' => 10),
  108. 3, 'num_text_rows: 3 rows, no breakage, blank line, no max row count');
  109. is($lsmb->num_text_rows('string' => "012345 67890123456789", 'cols' => 10),
  110. 3, 'num_text_rows: 3 rows, word and non column breakage, no max row count');
  111. # $lsmb->debug checks
  112. $lsmb = new LedgerSMB;
  113. @r = trap{$lsmb->debug($lsmb)};
  114. like($trap->stdout, qr|\n\$VAR1 = bless\( {[\n\s]+'action' => '',[\n\s]+'dbversion' => '\d+\.\d+\.\d+',[\n\s]+'path' => 'bin/mozilla',[\n\s]+'version' => '$lsmb->{version}'[\n\s]+}, 'LedgerSMB' \);|,
  115. 'debug: $lsmb, no file');
  116. SKIP: {
  117. skip 'Environment for file test not clean' if -f "t/var/lsmb-11.$$";
  118. $lsmb->{file} = "t/var/lsmb-11.$$";
  119. $lsmb->debug('file' => $lsmb->{file}, $lsmb);
  120. ok(-f "t/var/lsmb-11.$$", "debug: output file t/var/lsmb-11.$$ created");
  121. open(my $FH, '<', "t/var/lsmb-11.$$");
  122. my @str = <$FH>;
  123. close($FH);
  124. chomp(@str);
  125. like(join("\n", @str), qr|\$VAR1 = 'file';\n\$VAR2 = 't/var/lsmb-11.$$';\n\$VAR3 = bless\( {[\n\s]+'action' => '',[\n\s]+'dbversion' => '\d+\.\d+\.\d+',[\n\s]+'file' => 't/var/lsmb-11.$$',[\n\s]+'path' => 'bin/mozilla',[\n\s]+'version' => '$lsmb->{version}'[\n\s]+}, 'LedgerSMB' \);|,
  126. 'debug: $lsmb with file, contents');
  127. is(unlink("t/var/lsmb-11.$$"), 1, "debug: removing t/var/lsmb-11.$$");
  128. ok(!-e "t/var/lsmb-11.$$", "debug: t/var/lsmb-11.$$ removed");
  129. };
  130. $lsmb->{file} = 't/this is a bad directory, I do not exist/foo';
  131. @r = trap {$lsmb->debug('file' => $lsmb->{file}, $lsmb)};
  132. like($trap->die, qr/No such file or directory/,
  133. "debug: open failure causes death");
  134. ok(!-e $lsmb->{file}, "debug: file creation failed");
  135. # $lsmb->new checks
  136. $lsmb = new LedgerSMB;
  137. ok(defined $lsmb, 'new: blank, defined');
  138. isa_ok($lsmb, 'LedgerSMB', 'new: blank, correct type');
  139. ok(defined $lsmb->{action}, 'new: blank, action defined');
  140. ok(defined $lsmb->{dbversion}, 'new: blank, dbversion defined');
  141. ok(defined $lsmb->{path}, 'new: blank, path defined');
  142. ok(defined $lsmb->{version}, 'new: blank, version defined');
  143. $lsmb = new LedgerSMB('action=Apple%20sauce');
  144. ok(defined $lsmb, 'new: action set, defined');
  145. isa_ok($lsmb, 'LedgerSMB', 'new: action set, correct type');
  146. ok(defined $lsmb->{action}, 'new: action set, action defined');
  147. is($lsmb->{action}, 'apple_sauce', 'new: action set, action processed');
  148. ok(defined $lsmb->{dbversion}, 'new: action set, dbversion defined');
  149. ok(defined $lsmb->{path}, 'new: action set, path defined');
  150. ok(defined $lsmb->{version}, 'new: action set, version defined');
  151. $lsmb = new LedgerSMB('path=bin/lynx');
  152. ok(defined $lsmb, 'new: lynx, defined');
  153. isa_ok($lsmb, 'LedgerSMB', 'new: lynx, correct type');
  154. ok(defined $lsmb->{action}, 'new: lynx, action defined');
  155. ok(defined $lsmb->{dbversion}, 'new: lynx, dbversion defined');
  156. ok(defined $lsmb->{path}, 'new: lynx, path defined');
  157. is($lsmb->{path}, 'bin/lynx', 'new: lynx, path carried through');
  158. ok(defined $lsmb->{lynx}, 'new: lynx, lynx defined');
  159. is($lsmb->{lynx}, 1, 'new: lynx, lynx enabled');
  160. ok(defined $lsmb->{menubar}, 'new: lynx, menubar defined (deprecated)');
  161. is($lsmb->{menubar}, 1, 'new: lynx, menubar enabled (deprecated)');
  162. ok(defined $lsmb->{version}, 'new: lynx, version defined');
  163. @r = trap{new LedgerSMB('script=foo/bar.pl')};
  164. is($trap->die, "Error: Access Denied\n",
  165. 'new: directory traversal 1 caught');
  166. @r = trap{new LedgerSMB('script=foo\\bar.pl')};
  167. is($trap->die, "Error: Access Denied\n",
  168. 'new: directory traversal 2 caught');
  169. @r = trap{new LedgerSMB('script=..')};
  170. is($trap->die, "Error: Access Denied\n",
  171. 'new: directory traversal 3 caught');
  172. # $lsmb->redirect checks
  173. $lsmb = new LedgerSMB;
  174. ok(!defined $lsmb->{callback}, 'redirect: No callback set');
  175. @r = trap{$lsmb->redirect};
  176. is($trap->stdout, "redirected\n", 'redirect: No message or callback redirect');
  177. TODO: {
  178. local $TODO = '$lsmb->info for LedgerSMB';
  179. @r = trap{$lsmb->redirect('msg' => 'hello world')};
  180. is($trap->stdout, "hello world\n",
  181. 'redirect: message, no callback redirect');
  182. }
  183. $lsmb->{callback} = 1;
  184. @r = trap{$lsmb->redirect};
  185. is($trap->stdout, "redirected\n", 'redirect: callback, no message redirect');
  186. @r = trap{$lsmb->redirect('msg' => "hello world\n")};
  187. is($trap->stdout, "redirected\n", 'redirect: callback and message redirect');
  188. # $lsmb->call_procedure checks
  189. $lsmb = new LedgerSMB;
  190. $lsmb->{dbh} = ${LedgerSMB::Sysconfig::GLOBALDBH};
  191. @r = $lsmb->call_procedure('procname' => 'character_length',
  192. 'args' => ['month']);
  193. is($#r, 0, 'call_procedure: correct return length (one row)');
  194. is($r[0]->{'character_length'}, 5,
  195. 'call_procedure: single arg, non-numeric return');
  196. @r = $lsmb->call_procedure('procname' => 'trunc', 'args' => [57.1, 0]);
  197. is($r[0]->{'trunc'}, Math::BigFloat->new('57'),
  198. 'call_procedure: two args, numeric return');
  199. @r = $lsmb->call_procedure('procname' => 'pi', 'args' => []);
  200. like($r[0]->{'pi'}, qr/^3.14/,
  201. 'call_procedure: empty arg list, non-numeric return');
  202. # These tests are ugly and shouldn't work
  203. @r = $lsmb->call_procedure(
  204. 'procname' => 'power(2, 2) UNION ALL SELECT * FROM pi',
  205. 'args' => [], 'order_by' => 'power DESC');
  206. is($#r, 1, 'call_procedure: correct return length (two rows)');
  207. is($r[0]->{'power'}, 4, 'call_procedure: DESC ordering');
  208. @r = $lsmb->call_procedure(
  209. 'procname' => 'power(2, 2) UNION ALL SELECT * FROM pi',
  210. 'args' => [], 'order_by' => 'power ASC');
  211. is($r[1]->{'power'}, 4, 'call_procedure: ASC ordering');
  212. ##
  213. ##TODO: {
  214. ## local $TODO = 'Breaks when no arglist given';
  215. ## @r = $lsmb->call_procedure('procname' => 'pi');
  216. ## like($r[0]->{'pi'}, qr/^3.14/,
  217. ## 'call_procedure: no args, non-numeric return');
  218. ##}
  219. # $lsmb->merge checks
  220. $lsmb = new LedgerSMB;
  221. $lsmb->merge({'apple' => 1, 'pear' => 2, 'peach' => 3}, 'keys' => ['apple', 'pear']);
  222. ok(!defined $lsmb->{peach}, 'merge: Did not add unselected key');
  223. is($lsmb->{apple}, 1, 'merge: Added unselected key apple');
  224. is($lsmb->{pear}, 2, 'merge: Added unselected key pear');
  225. like($lsmb->{path}, qr#bin/(lynx|mozilla)#, 'merge: left existing key');
  226. $lsmb = new LedgerSMB;
  227. $lsmb->merge({'apple' => 1, 'pear' => 2, 'peach' => 3});
  228. is($lsmb->{apple}, 1, 'merge: No key, added apple');
  229. is($lsmb->{pear}, 2, 'merge: No key, added pear');
  230. is($lsmb->{peach}, 3, 'merge: No key, added peach');
  231. like($lsmb->{path}, qr#bin/(lynx|mozilla)#, 'merge: No key, left existing key');
  232. $lsmb = new LedgerSMB;
  233. $lsmb->merge({'apple' => 1, 'pear' => 2, 'peach' => 3}, 'index' => 1);
  234. is($lsmb->{apple_1}, 1, 'merge: Index 1, added apple as apple_1');
  235. is($lsmb->{pear_1}, 2, 'merge: Index 1, added pear as pear_1');
  236. is($lsmb->{peach_1}, 3, 'merge: Index 1, added peach as peach_1');
  237. like($lsmb->{path}, qr#bin/(lynx|mozilla)#, 'merge: Index 1, left existing key');
  238. # $lsmb->is_allowed_role checks
  239. $lsmb = new LedgerSMB;
  240. $lsmb->{_roles} = ('apple', 'pear');
  241. is($lsmb->is_allowed_role('allowed_roles' => ['pear']), 1,
  242. 'is_allowed_role: allowed role');
  243. TODO: {
  244. local $TODO = 'role system unimplemented';
  245. $lsmb->{_roles} = ['apple', 'pear'];
  246. is($lsmb->is_allowed_role('allowed_roles' => ['peach']), 0,
  247. 'is_allowed_role: disallowed role');
  248. is($lsmb->is_allowed_role('allowed_roles' => []), 0,
  249. 'is_allowed_role: no allowable roles');
  250. delete $lsmb->{_roles};
  251. is($lsmb->is_allowed_role('allowed_roles' => ['apple']), 0,
  252. 'is_allowed_role: no roles for user');
  253. }