File Coverage

blib/lib/EntityModel/Transaction.pm
Criterion Covered Total %
statement 49 52 94.2
branch 13 16 81.2
condition 2 3 66.6
subroutine 16 17 94.1
pod 6 7 85.7
total 86 95 90.5


line stmt bran cond sub pod time code
1             package EntityModel::Transaction;
2             {
3             $EntityModel::Transaction::VERSION = '0.102';
4             }
5 17     17   14337 use EntityModel::Class;
  17         44  
  17         128  
6             use overload '&{}' => sub {
7 4     4   3589 my $self = shift;
8 4         14 sap($self, 'apply');
9 17     17   6955 }, fallback => 1;
  17         37  
  17         209  
10 17     17   14742 use Try::Tiny;
  17         39831  
  17         11231  
11              
12             =head1 NAME
13              
14             EntityModel::Transaction - transaction co-ordinator
15              
16             =head1 VERSION
17              
18             version 0.102
19              
20             =head1 SYNOPSIS
21              
22             See L.
23              
24             =head1 DESCRIPTION
25              
26             Contacts each L instance and requests that they join a new
27             transaction.
28              
29             See L.
30              
31             =head2 apply
32              
33             Applies the current transaction. Typically called as the last
34             step in the transaction codeblock. The &{} overload will call
35             this method (so you can use C< $tran->() > or C< $tran->apply >
36             interchangeably).
37              
38             Takes no parameters.
39              
40             Returns $self.
41              
42             =cut
43              
44             sub apply {
45 4     4 1 7 my $self = shift;
46              
47 4 100       19 return $self if $self->{rolled_back};
48             return $self unless try {
49             # commit
50 3     3   116 1;
51             } catch {
52 0     0   0 $self->mark_failure;
53 0         0 $self->mark_goodbye;
54 0         0 0
55 3 50       22 };
56 3         60 $self->mark_success;
57 3         9 $self->mark_goodbye;
58 3         12 $self;
59             }
60              
61             =head2 mark_failure
62              
63             Mark this transaction as failed, applying rollback if required, and
64             calls the failure coderef.
65              
66             Takes no parameters.
67              
68             Returns $self.
69              
70             =cut
71              
72             sub mark_failure {
73 2     2 1 5 my $self = shift;
74             # rollback here
75 2         6 $self->{rolled_back} = 1;
76 2 50       13 $self->{on_failure}->($self) if exists $self->{on_failure};
77 2         824 $self
78             }
79              
80             =head2 mark_success
81              
82             Mark this transaction as successful, committing if required, and
83             calls the success coderef.
84              
85             Takes no parameters.
86              
87             Returns $self.
88              
89             =cut
90              
91             sub mark_success {
92 3     3 1 7 my $self = shift;
93 3 100       19 $self->{on_success}->($self) if exists $self->{on_success};
94 3         670 $self
95             }
96              
97             =head2 mark_goodbye
98              
99             Mark this transaction as completed. Calls the C coderef
100             if available.
101              
102             Takes no parameters.
103              
104             Returns $self.
105              
106             =cut
107              
108             sub mark_goodbye {
109 5     5 1 8 my $self = shift;
110 5 100       40 $self->{on_goodbye}->($self) if exists $self->{on_goodbye};
111 5         1751 $self
112             }
113              
114             =head2 run
115              
116             Takes the following (named) parameters:
117              
118             =over 4
119              
120             =item *
121              
122             =back
123              
124             Returns $self.
125              
126             =cut
127              
128             sub run {
129 5     5 1 10 my $self = shift;
130 5         6 my $code = shift;
131 5         14 my %args = @_;
132 5         124 $self->{"on_$_"} = delete $args{$_} for grep exists $args{$_}, qw(success failure goodbye);
133             # Attempt the transaction bit, normally we'd expect
134             # this to set up a few deferred events and return
135             # quickly
136             return $self unless try {
137 5     5   202 sap($self, $code)->();
138 3         443 1;
139             } catch {
140             # Something went wrong, bail
141 2     2   952 $self->mark_failure;
142 2         9 $self->mark_goodbye;
143 2         14 0;
144 5 100       42 };
145 3         57 $self;
146             }
147              
148             sub commit {
149 5     5 0 431 my $self = shift;
150 5 100       27 return $self if $self->{rolled_back};
151 3         7 $self->{committed} = 1;
152 3         10 $self
153             }
154              
155             sub DESTROY {
156 5     5   1291 my $self = shift;
157 5 50 66     66 warn "did not finish" unless $self->{committed} || $self->{rolled_back};
158             }
159              
160             sub sap {
161 9     9 1 30 my ($self, $sub) = @_;
162 9         29 Scalar::Util::weaken $self;
163             return sub {
164 9     9   29 $self->$sub(@_);
165 9         54 };
166             }
167              
168             1;
169              
170             __END__