File Coverage

blib/lib/MongoDB/ClientSession.pm
Criterion Covered Total %
statement 39 179 21.7
branch 0 92 0.0
condition 0 53 0.0
subroutine 13 31 41.9
pod 9 10 90.0
total 61 365 16.7


line stmt bran cond sub pod time code
1             # Copyright 2018 - present MongoDB, Inc.
2             #
3             # Licensed under the Apache License, Version 2.0 (the "License");
4             # you may not use this file except in compliance with the License.
5             # You may obtain a copy of the License at
6             #
7             # http://www.apache.org/licenses/LICENSE-2.0
8             #
9             # Unless required by applicable law or agreed to in writing, software
10             # distributed under the License is distributed on an "AS IS" BASIS,
11             # WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
12             # See the License for the specific language governing permissions and
13             # limitations under the License.
14              
15 59     59   359 use strict;
  59         108  
  59         1550  
16 59     59   259 use warnings;
  59         130  
  59         1861  
17             package MongoDB::ClientSession;
18              
19             # ABSTRACT: MongoDB session and transaction management
20              
21 59     59   266 use version;
  59         102  
  59         1207  
22             our $VERSION = 'v2.2.2';
23              
24 59     59   46047 use MongoDB::Error 'EXCEEDED_TIME_LIMIT';
  59         335  
  59         4966  
25              
26 59     59   487 use Moo;
  59         115  
  59         284  
27 59     59   17047 use MongoDB::_Constants;
  59         125  
  59         6356  
28 59         499 use MongoDB::_Types qw(
29             Document
30             BSONTimestamp
31             TransactionState
32             Boolish
33             HostAddress
34 59     59   343 );
  59         121  
35 59         396 use Types::Standard qw(
36             Maybe
37             HashRef
38             InstanceOf
39             Int
40 59     59   57388 );
  59         114  
41 59     59   77471 use MongoDB::_TransactionOptions;
  59         205  
  59         1901  
42 59     59   29434 use Time::HiRes ();
  59         66601  
  59         1817  
43 59     59   360 use namespace::clean -except => 'meta';
  59         119  
  59         437  
44 59     59   63146 use MongoDB::Op::_EndTxn;
  59         193  
  59         1780  
45 59     59   380 use Safe::Isa;
  59         120  
  59         128605  
46              
47             #pod =attr client
48             #pod
49             #pod The client this session was created using. Sessions may only be used
50             #pod with the client that created them.
51             #pod
52             #pod =cut
53              
54             has client => (
55             is => 'ro',
56             isa => InstanceOf['MongoDB::MongoClient'],
57             required => 1,
58             );
59              
60             #pod =attr cluster_time
61             #pod
62             #pod Stores the last received C<$clusterTime> for the client session. This is an
63             #pod opaque value, to set it use the L function.
64             #pod
65             #pod =cut
66              
67             has cluster_time => (
68             is => 'rwp',
69             isa => Maybe[Document],
70             init_arg => undef,
71             default => undef,
72             );
73              
74             #pod =attr options
75             #pod
76             #pod Options provided for this particular session. Available options include:
77             #pod
78             #pod =for :list
79             #pod * C - If true, will enable causalConsistency for
80             #pod this session. For more information, see L
81             #pod Consistency|https://docs.mongodb.com/manual/core/read-isolation-consistency-recency/#causal-consistency>.
82             #pod Note that causalConsistency does not apply for unacknowledged writes.
83             #pod Defaults to true.
84             #pod * C - Options to use by default for transactions
85             #pod created with this session. If when creating a transaction, none or only some of
86             #pod the transaction options are defined, these options will be used as a fallback.
87             #pod Defaults to inheriting from the parent client. See L for
88             #pod available options.
89             #pod
90             #pod =cut
91              
92             has options => (
93             is => 'ro',
94             isa => HashRef,
95             required => 1,
96             # Shallow copy to prevent action at a distance.
97             # Upgrade to use Storable::dclone if a more complex option is required
98             coerce => sub {
99             # Will cause the isa requirement to fire
100             return unless defined( $_[0] ) && ref( $_[0] ) eq 'HASH';
101             $_[0] = {
102             causalConsistency => defined $_[0]->{causalConsistency}
103             ? $_[0]->{causalConsistency}
104             : 1,
105             defaultTransactionOptions => {
106             %{ $_[0]->{defaultTransactionOptions} || {} }
107             },
108             };
109             },
110             );
111              
112             has _server_session => (
113             is => 'ro',
114             isa => InstanceOf['MongoDB::_ServerSession'],
115             init_arg => 'server_session',
116             required => 1,
117             clearer => '__clear_server_session',
118             );
119              
120             has _current_transaction_options => (
121             is => 'rwp',
122             isa => InstanceOf[ 'MongoDB::_TransactionOptions' ],
123             handles => {
124             _get_transaction_write_concern => 'write_concern',
125             _get_transaction_read_concern => 'read_concern',
126             _get_transaction_read_preference => 'read_preference',
127             _get_transaction_max_commit_time_ms => 'max_commit_time_ms',
128             },
129             );
130              
131             has _address => (
132             is => 'rwp',
133             isa => HostAddress,
134             clearer => '_unpin_address',
135             );
136              
137             has _transaction_state => (
138             is => 'rwp',
139             isa => TransactionState,
140             default => 'none',
141             );
142              
143             # Flag used to say we are still in a transaction
144             has _active_transaction => (
145             is => 'rwp',
146             isa => Boolish,
147             default => 0,
148             );
149              
150             # Flag used to say whether any operations have been performed on the
151             # transaction
152             has _has_transaction_operations => (
153             is => 'rwp',
154             isa => Boolish,
155             default => 0,
156             );
157              
158             # Used for retries of commit transactions - also set during abort transaction
159             # but that cant be retried
160             has _has_attempted_end_transaction => (
161             is => 'rw',
162             isa => Boolish,
163             default => 0,
164             );
165              
166             #pod =attr operation_time
167             #pod
168             #pod The last operation time. This is updated when an operation is performed during
169             #pod this session, or when L is called. Used for causal
170             #pod consistency.
171             #pod
172             #pod =cut
173              
174             has operation_time => (
175             is => 'rwp',
176             isa => Maybe[BSONTimestamp],
177             init_arg => undef,
178             default => undef,
179             );
180              
181             # Used in recovery of transactions on a sharded cluster
182             has _recovery_token => (
183             is => 'rwp',
184             isa => Maybe[Document],
185             init_arg => undef,
186             default => undef,
187             );
188              
189             #pod =method session_id
190             #pod
191             #pod The session id for this particular session. This should be considered
192             #pod an opaque value. If C has been called, this returns C.
193             #pod
194             #pod =cut
195              
196             sub session_id {
197 0     0 1   my ($self) = @_;
198 0 0         return defined $self->_server_session ? $self->_server_session->session_id : undef;
199             }
200              
201             #pod =method get_latest_cluster_time
202             #pod
203             #pod my $cluster_time = $session->get_latest_cluster_time;
204             #pod
205             #pod Returns the latest cluster time, when compared with this session's recorded
206             #pod cluster time and the main client cluster time. If neither is defined, returns
207             #pod undef.
208             #pod
209             #pod =cut
210              
211             sub get_latest_cluster_time {
212 0     0 1   my ( $self ) = @_;
213              
214             # default to the client cluster time - may still be undef
215 0 0         if ( ! defined $self->cluster_time ) {
216 0           return $self->client->_cluster_time;
217             }
218              
219 0 0         if ( defined $self->client->_cluster_time ) {
220             # Both must be defined here so can just compare
221 0 0         if ( $self->cluster_time->{'clusterTime'}
222             > $self->client->_cluster_time->{'clusterTime'} ) {
223 0           return $self->cluster_time;
224             } else {
225 0           return $self->client->_cluster_time;
226             }
227             }
228              
229             # Could happen that this cluster_time is updated manually before the client
230 0           return $self->cluster_time;
231             }
232              
233              
234             #pod =method advance_cluster_time
235             #pod
236             #pod $session->advance_cluster_time( $cluster_time );
237             #pod
238             #pod Update the C<$clusterTime> for this session. Stores the value in
239             #pod L. If the cluster time provided is more recent than the sessions
240             #pod current cluster time, then the session will be updated to this provided value.
241             #pod
242             #pod Setting the C<$clusterTime> with a manually crafted value may cause a server
243             #pod error. It is recommended to only use C<$clusterTime> values retrieved from
244             #pod database calls.
245             #pod
246             #pod =cut
247              
248             sub advance_cluster_time {
249 0     0 1   my ( $self, $cluster_time ) = @_;
250              
251             return unless $cluster_time && exists $cluster_time->{clusterTime}
252 0 0 0       && ref($cluster_time->{clusterTime}) eq 'BSON::Timestamp';
      0        
253              
254             # Only update the cluster time if it is more recent than the current entry
255 0 0         if ( ! defined $self->cluster_time ) {
256 0           $self->_set_cluster_time( $cluster_time );
257             } else {
258 0 0         if ( $cluster_time->{'clusterTime'}
259             > $self->cluster_time->{'clusterTime'} ) {
260 0           $self->_set_cluster_time( $cluster_time );
261             }
262             }
263 0           return;
264             }
265              
266             #pod =method advance_operation_time
267             #pod
268             #pod $session->advance_operation_time( $operation_time );
269             #pod
270             #pod Update the L for this session. If the value provided is more
271             #pod recent than the sessions current operation time, then the session will be
272             #pod updated to this provided value.
273             #pod
274             #pod Setting C with a manually crafted value may cause a server
275             #pod error. It is recommended to only use an C retrieved from
276             #pod another session or directly from a database call.
277             #pod
278             #pod =cut
279              
280             sub advance_operation_time {
281 0     0 1   my ( $self, $operation_time ) = @_;
282              
283             # Just dont update operation_time if they've denied this, as it'l stop
284             # everywhere else that updates based on this value from the session
285 0 0         return unless $self->options->{causalConsistency};
286              
287 0 0 0       if ( !defined( $self->operation_time )
288             || ( $operation_time > $self->operation_time ) ) {
289 0           $self->_set_operation_time( $operation_time );
290             }
291 0           return;
292             }
293              
294             # Returns 1 if the session is in one of the specified transaction states.
295             # Returns a false value if not in any of the states defined as an argument.
296             sub _in_transaction_state {
297 0     0     my ( $self, @states ) = @_;
298 0 0         return 1 if scalar ( grep { $_ eq $self->_transaction_state } @states );
  0            
299 0           return;
300             }
301              
302             #pod =method start_transaction
303             #pod
304             #pod $session->start_transaction;
305             #pod $session->start_transaction( $options );
306             #pod
307             #pod Start a transaction in this session. If a transaction is already in
308             #pod progress or if the driver can detect that the client is connected to a
309             #pod topology that does not support transactions, this method will throw an
310             #pod error.
311             #pod
312             #pod A hash reference of options may be provided. Valid keys include:
313             #pod
314             #pod =for :list
315             #pod * C - The read concern to use for the first command in this
316             #pod transaction. If not defined here or in the C in
317             #pod L, will inherit from the parent client.
318             #pod * C - The write concern to use for committing or aborting this
319             #pod transaction. As per C, if not defined here then the value defined
320             #pod in C will be used, or the parent client if not
321             #pod defined.
322             #pod * C - The read preference to use for all read operations in
323             #pod this transaction. If not defined, then will inherit from
324             #pod C or from the parent client. This value will
325             #pod override all other read preferences set in any subsequent commands inside this
326             #pod transaction.
327             #pod * C - The C specifies a cumulative time limit in
328             #pod milliseconds for processing operations on the cursor. MongoDB interrupts the
329             #pod operation at the earliest following interrupt point.
330             #pod
331             #pod =cut
332              
333             sub start_transaction {
334 0     0 1   my ( $self, $opts ) = @_;
335              
336 0 0         MongoDB::UsageError->throw("Transaction already in progress")
337             if $self->_in_transaction_state( TXN_STARTING, TXN_IN_PROGRESS );
338              
339 0 0         MongoDB::ConfigurationError->throw("Transactions are unsupported on this deployment")
340             unless $self->client->_topology->_supports_transactions;
341              
342 0   0       $opts ||= {};
343             my $trans_opts = MongoDB::_TransactionOptions->new(
344             client => $self->client,
345             options => $opts,
346             default_options => $self->options->{defaultTransactionOptions},
347 0           );
348              
349 0           $self->_set__current_transaction_options( $trans_opts );
350              
351 0           $self->_set__transaction_state( TXN_STARTING );
352              
353 0           $self->_increment_transaction_id;
354              
355 0           $self->_unpin_address;
356 0           $self->_set__active_transaction( 1 );
357 0           $self->_set__has_transaction_operations( 0 );
358 0           $self->_has_attempted_end_transaction( 0 );
359              
360 0           return;
361             }
362              
363             sub _increment_transaction_id {
364 0     0     my $self = shift;
365 0 0         return if $self->_active_transaction;
366              
367 0           $self->_server_session->transaction_id->binc();
368             }
369              
370             #pod =method commit_transaction
371             #pod
372             #pod $session->commit_transaction;
373             #pod
374             #pod Commit the current transaction. This will use the writeConcern set on this
375             #pod transaction.
376             #pod
377             #pod If called when no transaction is in progress, then this method will throw
378             #pod an error.
379             #pod
380             #pod If the commit operation encounters an error, an error is thrown. If the
381             #pod error is a transient commit error, the error object will have a label
382             #pod containing "UnknownTransactionCommitResult" as an element and the commit
383             #pod operation can be retried. This can be checked via the C:
384             #pod
385             #pod LOOP: {
386             #pod eval {
387             #pod $session->commit_transaction;
388             #pod };
389             #pod if ( my $error = $@ ) {
390             #pod if ( $error->has_error_label("UnknownTransactionCommitResult") ) {
391             #pod redo LOOP;
392             #pod }
393             #pod else {
394             #pod die $error;
395             #pod }
396             #pod }
397             #pod }
398             #pod
399             #pod =cut
400              
401             sub commit_transaction {
402 0     0 1   my $self = shift;
403              
404 0 0         MongoDB::UsageError->throw("No transaction started")
405             if $self->_in_transaction_state( TXN_NONE );
406              
407             # Error message tweaked to use our function names
408 0 0         MongoDB::UsageError->throw("Cannot call commit_transaction after calling abort_transaction")
409             if $self->_in_transaction_state( TXN_ABORTED );
410              
411             # Commit can be called multiple times - even if the transaction completes
412             # correctly. Setting this here makes sure we dont increment transaction id
413             # until after another command has been called using this session
414 0           $self->_set__active_transaction( 1 );
415              
416 0           my $max_time_ms = $self->_get_transaction_max_commit_time_ms;
417 0           eval {
418 0 0         $self->_send_end_transaction_command( TXN_COMMITTED, [
419             commitTransaction => 1,
420             defined($max_time_ms) ? (maxTimeMS => $max_time_ms) : ()
421             ] );
422             };
423 0 0         if ( my $err = $@ ) {
424             # catch and re-throw after retryable errors
425 0           my $err_code_name;
426             my $err_code;
427 0 0         if ( $err->can('result') ) {
428 0 0         if ( $err->result->can('output') ) {
429 0           $err_code_name = $err->result->output->{codeName};
430 0           $err_code = $err->result->output->{code};
431             $err_code_name ||= $err->result->output->{writeConcernError}
432             ? $err->result->output->{writeConcernError}->{codeName}
433 0 0 0       : ''; # Empty string just in case
434             $err_code ||= $err->result->output->{writeConcernError}
435             ? $err->result->output->{writeConcernError}->{code}
436 0 0 0       : 0; # just in case
437             }
438             }
439             # If its a write concern error, retrying a commit would still error
440 0 0 0       unless (
      0        
      0        
441 0           ( defined( $err_code_name ) && grep { $_ eq $err_code_name } qw/
442             CannotSatisfyWriteConcern
443             UnsatisfiableWriteConcern
444             UnknownReplWriteConcern
445             NoSuchTransaction
446             / )
447             # Spec tests include code numbers only with no codeName
448 0           || ( defined ( $err_code ) && grep { $_ == $err_code }
449             100, # UnsatisfiableWriteConcern/CannotSatisfyWriteConcern
450             79, # UnknownReplWriteConcern
451             251, # NoSuchTransaction
452             )
453             ) {
454 0 0         push @{ $err->error_labels }, TXN_UNKNOWN_COMMIT_MSG
  0            
455             unless $err->has_error_label( TXN_UNKNOWN_COMMIT_MSG );
456             }
457 0           die $err;
458             }
459              
460 0           return;
461             }
462              
463             #pod =method abort_transaction
464             #pod
465             #pod $session->abort_transaction;
466             #pod
467             #pod Aborts the current transaction. If no transaction is in progress, then this
468             #pod method will throw an error. Otherwise, this method will suppress all other
469             #pod errors (including network and database errors).
470             #pod
471             #pod =cut
472              
473             sub abort_transaction {
474 0     0 1   my $self = shift;
475              
476 0 0         MongoDB::UsageError->throw("No transaction started")
477             if $self->_in_transaction_state( TXN_NONE );
478              
479             # Error message tweaked to use our function names
480 0 0         MongoDB::UsageError->throw("Cannot call abort_transaction after calling commit_transaction")
481             if $self->_in_transaction_state( TXN_COMMITTED );
482              
483             # Error message tweaked to use our function names
484 0 0         MongoDB::UsageError->throw("Cannot call abort_transaction twice")
485             if $self->_in_transaction_state( TXN_ABORTED );
486              
487             # Ignore all errors thrown by abortTransaction
488 0           eval {
489 0           $self->_send_end_transaction_command( TXN_ABORTED, [ abortTransaction => 1 ] );
490             };
491              
492             # Make sure active transaction is turned off, even when the command itself fails
493 0           $self->_set__active_transaction( 0 );
494              
495 0           return;
496             }
497              
498             sub _send_end_transaction_command {
499 0     0     my ( $self, $end_state, $command ) = @_;
500              
501 0           $self->_set__transaction_state( $end_state );
502              
503             # Only need to send commit command if the transaction actually sent anything
504 0 0         if ( $self->_has_transaction_operations ) {
505 0           my $op = MongoDB::Op::_EndTxn->_new(
506             db_name => 'admin',
507             query => $command,
508             bson_codec => $self->client->bson_codec,
509             session => $self,
510             monitoring_callback => $self->client->monitoring_callback,
511             );
512              
513 0           my $result = $self->client->send_retryable_write_op( $op, 'force' );
514             }
515              
516             # If the commit/abort succeeded, we are no longer in an active transaction
517 0           $self->_set__active_transaction( 0 );
518             }
519              
520             # For applying connection errors etc
521             sub _maybe_apply_error_labels_and_unpin {
522 0     0     my ( $self, $err ) = @_;
523              
524 0 0         if ( $self->_in_transaction_state( TXN_STARTING, TXN_IN_PROGRESS ) ) {
    0          
525 0 0 0       $err->add_error_label( TXN_TRANSIENT_ERROR_MSG )
526             if $err->$_isa("MongoDB::Error") && $err->_is_transient_transaction_error;
527             } elsif ( $self->_in_transaction_state( TXN_COMMITTED ) ) {
528 0 0 0       $err->add_error_label( TXN_UNKNOWN_COMMIT_MSG )
529             if $err->$_isa("MongoDB::Error") && $err->_is_unknown_commit_error;
530             }
531 0           $self->_maybe_unpin_address( $err->error_labels );
532 0           return;
533             }
534              
535             # Passed an arrayref of error labels. Used where the client session isnt actively
536             # adding the label (like from the database, in CommandResult), nor is the
537             # calling class able to pass a constructed error
538             sub _maybe_unpin_address {
539 0     0     my ( $self, $error_labels ) = @_;
540              
541 0           my %labels = ( map { $_ => 1 } @$error_labels );
  0            
542 0 0 0       if ( $labels{ +TXN_TRANSIENT_ERROR_MSG }
      0        
543             # Must also unpin if its an unknown commit error during a commit
544             || ( $self->_in_transaction_state( TXN_COMMITTED )
545             && $labels{ +TXN_UNKNOWN_COMMIT_MSG } )
546             ) {
547 0           $self->_unpin_address;
548             }
549             }
550              
551             #pod =method end_session
552             #pod
553             #pod $session->end_session;
554             #pod
555             #pod Close this particular session and release the session ID for reuse or
556             #pod recycling. If a transaction is in progress, it will be aborted. Has no
557             #pod effect after calling for the first time.
558             #pod
559             #pod This will be called automatically by the object destructor.
560             #pod
561             #pod =cut
562              
563             sub end_session {
564 0     0 1   my ( $self ) = @_;
565              
566 0 0         if ( $self->_in_transaction_state ( TXN_IN_PROGRESS ) ) {
567             # Ignore all errors
568 0           eval { $self->abort_transaction };
  0            
569             }
570 0 0         if ( defined $self->_server_session ) {
571 0           $self->client->_server_session_pool->retire_server_session( $self->_server_session );
572 0           $self->__clear_server_session;
573             }
574             }
575              
576             #pod =method with_transaction
577             #pod
578             #pod $session->with_transaction($callback, $options);
579             #pod
580             #pod Execute a callback in a transaction.
581             #pod
582             #pod This method starts a transaction on this session, executes C<$callback>, and
583             #pod then commits the transaction, returning the return value of the C<$callback>.
584             #pod The C<$callback> will be executed at least once.
585             #pod
586             #pod If the C<$callback> throws an error, the transaction will be aborted. If less
587             #pod than 120 seconds have passed since calling C, and the error
588             #pod has a C label, the transaction will be restarted and
589             #pod the callback will be executed again. Otherwise, the error will be thrown.
590             #pod
591             #pod If the C<$callback> succeeds, then the transaction will be committed. If an
592             #pod error is thrown from committing the transaction, and it is less than 120
593             #pod seconds since calling C, then:
594             #pod
595             #pod =for :list
596             #pod * If the error has a C label, the transaction will be
597             #pod restarted.
598             #pod * If the error has an C label, and is not a
599             #pod C error, then the commit will be retried.
600             #pod
601             #pod If the C<$callback> aborts or commits the transaction, no other actions are
602             #pod taken and the return value of the C<$callback> is returned.
603             #pod
604             #pod The callback is called with the first (and only) argument being the session,
605             #pod after starting the transaction:
606             #pod
607             #pod $session->with_transaction( sub {
608             #pod # this is the same session as used for with_transaction
609             #pod my $cb_session = shift;
610             #pod ...
611             #pod }, $options);
612             #pod
613             #pod To pass arbitrary arguments to the C<$callback>, wrap your callback in a coderef:
614             #pod
615             #pod $session->with_transaction(sub { $callback->($session, $foo, ...) }, $options);
616             #pod
617             #pod B: you must either use the provided session within the callback, or
618             #pod otherwise pass the session in use to the callback. You must pass the
619             #pod C<$session> as an option to all database operations that need to be included
620             #pod in the transaction.
621             #pod
622             #pod B: The C<$callback> can be called multiple times, so it is recommended
623             #pod to make it idempotent.
624             #pod
625             #pod A hash reference of options may be provided. these are the same as for
626             #pod L.
627             #pod
628             #pod =cut
629              
630             # We may not have a monotonic clock, but must use one for checking time limits
631             my $HAS_MONOTONIC = eval { Time::HiRes::clock_gettime(Time::HiRes::CLOCK_MONOTONIC()); 1 };
632 0     0     *monotonic_time = $HAS_MONOTONIC ? sub { Time::HiRes::clock_gettime(Time::HiRes::CLOCK_MONOTONIC()) } : \&Time::HiRes::time;
633              
634             sub _within_time_limit {
635 0     0     my ($self, $start_time) = @_;
636 0           return monotonic_time() - $start_time < WITH_TXN_RETRY_TIME_LIMIT;
637             }
638              
639             sub _is_commit_timeout_error {
640 0     0     my ($self, $err) = @_;
641 0 0 0       if ( $err->can('result') && $err->result->can('output') ) {
642 0           my $output = $err->result->output;
643 0           my $err_code = $output->{ code };
644 0           my $err_codename = $output->{ codeName };
645 0 0         if ( defined $output->{ writeConcernError } ) {
646 0           $err_code = $output->{ writeConcernError }->{ code };
647 0           $err_codename = $output->{ writeConcernError }->{ codeName };
648             }
649 0 0 0       return 1 if ( $err_code == EXCEEDED_TIME_LIMIT ) || ( $err_codename eq 'MaxTimeMSExpired' );
650             }
651 0           return;
652             }
653              
654             sub with_transaction {
655 0     0 1   my ( $self, $callback, $options ) = @_;
656 0           my $start_time = monotonic_time();
657 0           TRANSACTION: while (1) {
658 0           $self->start_transaction($options);
659              
660 0           my $ret = eval { $callback->($self) };
  0            
661 0 0         if (my $err = $@) {
662 0 0         if ( $self->_in_transaction_state(TXN_STARTING, TXN_IN_PROGRESS) ) {
663             # Ignore all errors
664 0           eval { $self->abort_transaction };
  0            
665             }
666 0 0 0       if ( $err->$_isa('MongoDB::Error')
      0        
667             && $err->has_error_label(TXN_TRANSIENT_ERROR_MSG)
668             && $self->_within_time_limit($start_time) ) {
669             # Set inactive transaction to force transaction id to increment on next start
670 0           $self->_set__active_transaction(0);
671 0           next TRANSACTION;
672             }
673 0           die $err;
674             }
675 0 0         if ( $self->_in_transaction_state(TXN_NONE, TXN_COMMITTED, TXN_ABORTED) ) {
676             # Assume callback intentionally ended the transaction
677 0           return $ret;
678             }
679              
680 0           COMMIT: while (1) {
681 0           eval { $self->commit_transaction };
  0            
682 0 0         if (my $err = $@) {
683 0 0         if ( $err->$_isa('MongoDB::Error') ) {
684 0 0         if ( $self->_within_time_limit($start_time) ) {
685             # Order is important here - a transient transaction
686             # error means the entire transaction may have gone
687             # wrong, whereas an unknown commit means only the
688             # commit may have failed.
689 0 0         if ( $err->has_error_label(TXN_TRANSIENT_ERROR_MSG) ) {
690             # Set inactive transaction to force transaction id to increment on next start
691 0           $self->_set__active_transaction(0);
692 0           next TRANSACTION;
693             }
694 0 0 0       if ( $err->has_error_label(TXN_UNKNOWN_COMMIT_MSG)
695             && ! $self->_is_commit_timeout_error( $err ) )
696             {
697 0           next COMMIT;
698             }
699              
700             }
701             }
702 0           die $err;
703             }
704             # Commit succeeded
705 0           return $ret;
706             }
707             }
708             }
709              
710             sub DEMOLISH {
711 0     0 0   my ( $self, $in_global_destruction ) = @_;
712             # Implicit end of session in scope
713 0           $self->end_session;
714             }
715              
716             1;
717              
718             __END__