a2d8267 13 years ago
3 contributor
573 lines | 13.334kb
  1. package DBIx::Custom::Result;
  2. use Object::Simple -base;
  3.  
  4. use Carp 'croak';
  5. use DBIx::Custom::Util qw/_array_to_hash _subname/;
  6.  
  7. has [qw/dbi sth/],
  8. stash => sub { {} };
  9.  
  10. *all = \&fetch_hash_all;
  11.  
  12. sub filter {
  13. my $self = shift;
  14. # Set
  15. if (@_) {
  16. # Convert filter name to subroutine
  17. my $filter = @_ == 1 ? $_[0] : [@_];
  18. $filter = _array_to_hash($filter);
  19. foreach my $column (keys %$filter) {
  20. my $fname = $filter->{$column};
  21. if (exists $filter->{$column}
  22. && defined $fname
  23. && ref $fname ne 'CODE')
  24. {
  25. croak qq{Filter "$fname" is not registered" } . _subname
  26. unless exists $self->dbi->filters->{$fname};
  27. $filter->{$column} = $self->dbi->filters->{$fname};
  28. }
  29. }
  30. # Merge
  31. $self->{filter} = {%{$self->filter}, %$filter};
  32. return $self;
  33. }
  34. return $self->{filter} ||= {};
  35. }
  36.  
  37. sub filter_off {
  38. my $self = shift;
  39. $self->{filter_off} = 1;
  40. return $self;
  41. }
  42.  
  43. sub filter_on {
  44. my $self = shift;
  45. $self->{filter_off} = 0;
  46. return $self;
  47. }
  48.  
  49. sub fetch {
  50. my $self = shift;
  51. # Info
  52. my $columns = $self->{sth}->{NAME};
  53. my $types = $self->{sth}->{TYPE};
  54. # Fetch
  55. my @row = $self->{sth}->fetchrow_array;
  56. return unless @row;
  57. # Filtering
  58. my $type_rule1 = $self->type_rule->{from1} || {};
  59. my $type_rule2 = $self->type_rule->{from2} || {};
  60. my $filter = $self->filter;
  61. my $end_filter = $self->{end_filter} || {};
  62. for (my $i = 0; $i < @$columns; $i++) {
  63. # Column
  64. my $column = $columns->[$i];
  65. # Type rule
  66. my $type_filter1 = $type_rule1->{lc($types->[$i])};
  67. $row[$i] = $type_filter1->($row[$i])
  68. if $type_filter1 && !$self->{type_rule_off}
  69. && !$self->{type_rule1_off};
  70. my $type_filter2 = $type_rule2->{lc($types->[$i])};
  71. $row[$i] = $type_filter2->($row[$i])
  72. if $type_filter2 && !$self->{type_rule_off}
  73. && !$self->{type_rule2_off};
  74. # Filter
  75. my $filter = $filter->{$column} || $self->{default_filter};
  76. $row[$i] = $filter->($row[$i])
  77. if $filter && !$self->{filter_off};
  78. $row[$i] = $end_filter->{$column}->($row[$i])
  79. if $end_filter->{$column} && !$self->{filter_off};
  80. }
  81.  
  82. return \@row;
  83. }
  84.  
  85. sub fetch_all {
  86. my $self = shift;
  87. # Fetch all rows
  88. my $rows = [];
  89. while(my $row = $self->fetch) { push @$rows, $row}
  90. return $rows;
  91. }
  92.  
  93. sub fetch_first {
  94. my $self = shift;
  95. # Fetch
  96. my $row = $self->fetch;
  97. return unless $row;
  98. # Finish statement handle
  99. $self->sth->finish;
  100. return $row;
  101. }
  102.  
  103. sub fetch_hash {
  104. my $self = shift;
  105. # Info
  106. my $columns = $self->{sth}->{NAME};
  107. my $types = $self->{sth}->{TYPE};
  108. # Fetch
  109. my $row = $self->{sth}->fetchrow_arrayref;
  110. return unless $row;
  111.  
  112. # Filter
  113. my $hash_row = {};
  114. my $filter = $self->filter;
  115. my $end_filter = $self->{end_filter} || {};
  116. my $type_rule1 = $self->type_rule->{from1} || {};
  117. my $type_rule2 = $self->type_rule->{from2} || {};
  118. for (my $i = 0; $i < @$columns; $i++) {
  119. # Column
  120. my $column = $columns->[$i];
  121. $hash_row->{$column} = $row->[$i];
  122. # Type rule
  123. my $type_filter1 = $type_rule1->{lc($types->[$i])};
  124. $hash_row->{$column} = $type_filter1->($hash_row->{$column})
  125. if !$self->{type_rule_off} && !$self->{type_rule1_off}
  126. && $type_filter1;
  127. my $type_filter2 = $type_rule2->{lc($types->[$i])};
  128. $hash_row->{$column} = $type_filter2->($hash_row->{$column})
  129. if !$self->{type_rule_off} && !$self->{type_rule2_off}
  130. && $type_filter2;
  131. # Filter
  132. my $f = $filter->{$column} || $self->{default_filter};
  133. $hash_row->{$column} = $f->($hash_row->{$column})
  134. if $f && !$self->{filter_off};
  135. $hash_row->{$column} = $end_filter->{$column}->($hash_row->{$column})
  136. if $end_filter->{$column} && !$self->{filter_off};
  137. }
  138. return $hash_row;
  139. }
  140.  
  141. sub fetch_hash_all {
  142. my $self = shift;
  143. # Fetch all rows as hash
  144. my $rows = [];
  145. while(my $row = $self->fetch_hash) { push @$rows, $row }
  146. return $rows;
  147. }
  148.  
  149. sub fetch_hash_first {
  150. my $self = shift;
  151. # Fetch hash
  152. my $row = $self->fetch_hash;
  153. return unless $row;
  154. # Finish statement handle
  155. $self->sth->finish;
  156. return $row;
  157. }
  158.  
  159. sub fetch_hash_multi {
  160. my ($self, $count) = @_;
  161. # Fetch multiple rows
  162. croak 'Row count must be specified ' . _subname
  163. unless $count;
  164. my $rows = [];
  165. for (my $i = 0; $i < $count; $i++) {
  166. my $row = $self->fetch_hash;
  167. last unless $row;
  168. push @$rows, $row;
  169. }
  170. return unless @$rows;
  171. return $rows;
  172. }
  173.  
  174. sub fetch_multi {
  175. my ($self, $count) = @_;
  176. # Row count not specifed
  177. croak 'Row count must be specified ' . _subname
  178. unless $count;
  179. # Fetch multi rows
  180. my $rows = [];
  181. for (my $i = 0; $i < $count; $i++) {
  182. my $row = $self->fetch;
  183. last unless $row;
  184. push @$rows, $row;
  185. }
  186. return unless @$rows;
  187. return $rows;
  188. }
  189.  
  190. sub header { shift->sth->{NAME} }
  191.  
  192. *one = \&fetch_hash_first;
  193.  
  194. sub type_rule {
  195. my $self = shift;
  196. if (@_) {
  197. my $type_rule = ref $_[0] eq 'HASH' ? $_[0] : {@_};
  198.  
  199. # From
  200. foreach my $i (1 .. 2) {
  201. $type_rule->{"from$i"} = _array_to_hash($type_rule->{"from$i"});
  202. foreach my $data_type (keys %{$type_rule->{"from$i"} || {}}) {
  203. croak qq{data type of from$i section must be lower case or number}
  204. if $data_type =~ /[A-Z]/;
  205. my $fname = $type_rule->{"from$i"}{$data_type};
  206. if (defined $fname && ref $fname ne 'CODE') {
  207. croak qq{Filter "$fname" is not registered" } . _subname
  208. unless exists $self->dbi->filters->{$fname};
  209. $type_rule->{"from$i"}{$data_type} = $self->dbi->filters->{$fname};
  210. }
  211. }
  212. }
  213. $self->{type_rule} = $type_rule;
  214. return $self;
  215. }
  216. return $self->{type_rule} || {};
  217. }
  218.  
  219. sub type_rule_off {
  220. my $self = shift;
  221. $self->{type_rule_off} = 1;
  222. return $self;
  223. }
  224.  
  225. sub type_rule_on {
  226. my $self = shift;
  227. $self->{type_rule_off} = 0;
  228. return $self;
  229. }
  230.  
  231. sub type_rule1_off {
  232. my $self = shift;
  233. $self->{type_rule1_off} = 1;
  234. return $self;
  235. }
  236.  
  237. sub type_rule1_on {
  238. my $self = shift;
  239. $self->{type_rule1_off} = 0;
  240. return $self;
  241. }
  242.  
  243. sub type_rule2_off {
  244. my $self = shift;
  245. $self->{type_rule2_off} = 1;
  246. return $self;
  247. }
  248.  
  249. sub type_rule2_on {
  250. my $self = shift;
  251. $self->{type_rule2_off} = 0;
  252. return $self;
  253. }
  254.  
  255. # DEPRECATED!
  256. sub end_filter {
  257. warn "end_filter method is DEPRECATED!";
  258. my $self = shift;
  259. if (@_) {
  260. my $end_filter = {};
  261. if (ref $_[0] eq 'HASH') { $end_filter = $_[0] }
  262. else {
  263. $end_filter = _array_to_hash(
  264. @_ > 1 ? [@_] : $_[0]
  265. );
  266. }
  267. foreach my $column (keys %$end_filter) {
  268. my $fname = $end_filter->{$column};
  269. if (exists $end_filter->{$column}
  270. && defined $fname
  271. && ref $fname ne 'CODE')
  272. {
  273. croak qq{Filter "$fname" is not registered" } . _subname
  274. unless exists $self->dbi->filters->{$fname};
  275. $end_filter->{$column} = $self->dbi->filters->{$fname};
  276. }
  277. }
  278. $self->{end_filter} = {%{$self->end_filter}, %$end_filter};
  279. return $self;
  280. }
  281. return $self->{end_filter} ||= {};
  282. }
  283. # DEPRECATED!
  284. sub remove_end_filter {
  285. warn "remove_end_filter is DEPRECATED!";
  286. my $self = shift;
  287. $self->{end_filter} = {};
  288. return $self;
  289. }
  290. # DEPRECATED!
  291. sub remove_filter {
  292. warn "remove_filter is DEPRECATED!";
  293. my $self = shift;
  294. $self->{filter} = {};
  295. return $self;
  296. }
  297. # DEPRECATED!
  298. sub default_filter {
  299. warn "default_filter is DEPRECATED!";
  300. my $self = shift;
  301. if (@_) {
  302. my $fname = $_[0];
  303. if (@_ && !$fname) {
  304. $self->{default_filter} = undef;
  305. }
  306. else {
  307. croak qq{Filter "$fname" is not registered}
  308. unless exists $self->dbi->filters->{$fname};
  309. $self->{default_filter} = $self->dbi->filters->{$fname};
  310. }
  311. return $self;
  312. }
  313. return $self->{default_filter};
  314. }
  315. # DEPRECATED!
  316. has 'filter_check';
  317.  
  318. 1;
  319.  
  320. =head1 NAME
  321.  
  322. DBIx::Custom::Result - Result of select statement
  323.  
  324. =head1 SYNOPSIS
  325.  
  326. # Result
  327. my $result = $dbi->select(table => 'book');
  328.  
  329. # Fetch a row and put it into array reference
  330. while (my $row = $result->fetch) {
  331. my $author = $row->[0];
  332. my $title = $row->[1];
  333. }
  334. # Fetch only a first row and put it into array reference
  335. my $row = $result->fetch_first;
  336. # Fetch all rows and put them into array of array reference
  337. my $rows = $result->fetch_all;
  338.  
  339. # Fetch a row and put it into hash reference
  340. while (my $row = $result->fetch_hash) {
  341. my $title = $row->{title};
  342. my $author = $row->{author};
  343. }
  344. # Fetch only a first row and put it into hash reference
  345. my $row = $result->fetch_hash_first;
  346. my $row = $result->one; # Same as fetch_hash_first
  347. # Fetch all rows and put them into array of hash reference
  348. my $rows = $result->fetch_hash_all;
  349. my $rows = $result->all; # Same as fetch_hash_all
  350.  
  351. =head1 ATTRIBUTES
  352.  
  353. =head2 C<dbi>
  354.  
  355. my $dbi = $result->dbi;
  356. $result = $result->dbi($dbi);
  357.  
  358. L<DBIx::Custom> object.
  359.  
  360. =head2 C<sth>
  361.  
  362. my $sth = $reuslt->sth
  363. $result = $result->sth($sth);
  364.  
  365. Statement handle of L<DBI>.
  366.  
  367. =head1 METHODS
  368.  
  369. L<DBIx::Custom::Result> inherits all methods from L<Object::Simple>
  370. and implements the following new ones.
  371.  
  372. =head2 C<all>
  373.  
  374. my $rows = $result->all;
  375.  
  376. Same as C<fetch_hash_all>.
  377.  
  378. =head2 C<fetch>
  379.  
  380. my $row = $result->fetch;
  381.  
  382. Fetch a row and put it into array reference.
  383.  
  384. =head2 C<fetch_all>
  385.  
  386. my $rows = $result->fetch_all;
  387.  
  388. Fetch all rows and put them into array of array reference.
  389.  
  390. =head2 C<fetch_first>
  391.  
  392. my $row = $result->fetch_first;
  393.  
  394. Fetch only a first row and put it into array reference,
  395. and finish statment handle.
  396.  
  397. =head2 C<fetch_hash>
  398.  
  399. my $row = $result->fetch_hash;
  400.  
  401. Fetch a row and put it into hash reference.
  402.  
  403. =head2 C<fetch_hash_all>
  404.  
  405. my $rows = $result->fetch_hash_all;
  406.  
  407. Fetch all rows and put them into array of hash reference.
  408.  
  409. =head2 C<fetch_hash_first>
  410. my $row = $result->fetch_hash_first;
  411.  
  412. Fetch only a first row and put it into hash reference,
  413. and finish statment handle.
  414.  
  415. =head2 C<fetch_hash_multi>
  416.  
  417. my $rows = $result->fetch_hash_multi(5);
  418. Fetch multiple rows and put them into array of hash reference.
  419.  
  420. =head2 C<fetch_multi>
  421.  
  422. my $rows = $result->fetch_multi(5);
  423. Fetch multiple rows and put them into array of array reference.
  424.  
  425. =head2 C<filter>
  426.  
  427. $result->filter(title => sub { uc $_[0] }, author => 'to_upper');
  428. $result->filter([qw/title author/] => 'to_upper');
  429.  
  430. Set filter for column.
  431. You can use subroutine or filter name as filter.
  432. This filter is executed after C<type_rule> filter.
  433.  
  434. =head2 C<filter_off> EXPERIMENTAL
  435.  
  436. $result = $result->filter_off;
  437.  
  438. Turn filtering by C<filter> method off.
  439. By default, filterin is on.
  440.  
  441. =head2 C<filter_on> EXPERIMENTAL
  442.  
  443. $result = $resutl->filter_on;
  444.  
  445. Turn filtering by C<filter> method on.
  446. By default, filterin is on.
  447.  
  448. =head2 C<header>
  449.  
  450. my $header = $result->header;
  451.  
  452. Get header column names.
  453.  
  454. =head2 C<one>
  455.  
  456. my $row = $result->one;
  457.  
  458. Same as C<fetch_hash_first>.
  459.  
  460. =head2 C<stash>
  461.  
  462. my $stash = $result->stash;
  463. my $foo = $result->stash->{foo};
  464. $result->stash->{foo} = $foo;
  465.  
  466. Stash is hash reference for data.
  467.  
  468. =head2 C<type_rule> EXPERIMENTAL
  469. # Merge type rule
  470. $result->type_rule(
  471. # DATE
  472. 9 => sub { ... },
  473. # DATETIME or TIMESTAMP
  474. 11 => sub { ... }
  475. );
  476.  
  477. # Replace type rule(by reference)
  478. $result->type_rule([
  479. # DATE
  480. 9 => sub { ... },
  481. # DATETIME or TIMESTAMP
  482. 11 => sub { ... }
  483. ]);
  484.  
  485. This is same as L<DBIx::Custom>'s C<type_rule>'s <from>.
  486.  
  487. =head2 C<type_rule_off> EXPERIMENTAL
  488.  
  489. $result = $result->type_rule_off;
  490.  
  491. Turn C<from1> and C<from2> type rule off.
  492. By default, type rule is on.
  493.  
  494. =head2 C<type_rule_on> EXPERIMENTAL
  495.  
  496. $result = $result->type_rule_on;
  497.  
  498. Turn C<from1> and C<from2> type rule on.
  499. By default, type rule is on.
  500.  
  501. =head2 C<type_rule1_off> EXPERIMENTAL
  502.  
  503. $result = $result->type_rule1_off;
  504.  
  505. Turn C<from1> type rule off.
  506. By default, type rule is on.
  507.  
  508. =head2 C<type_rule1_on> EXPERIMENTAL
  509.  
  510. $result = $result->type_rule1_on;
  511.  
  512. Turn C<from1> type rule on.
  513. By default, type rule is on.
  514.  
  515. =head2 C<type_rule2_off> EXPERIMENTAL
  516.  
  517. $result = $result->type_rule2_off;
  518.  
  519. Turn C<from2> type rule off.
  520. By default, type rule is on.
  521.  
  522. =head2 C<type_rule2_on> EXPERIMENTAL
  523.  
  524. $result = $result->type_rule2_on;
  525.  
  526. Turn C<from2> type rule on.
  527. By default, type rule is on.
  528.  
  529. =cut