view release on metacpan or  search on metacpan

lib/DBIx/OnlineDDL.pm  view on Meta::CPAN

        # $storage->connect_info.  We are also not attaching these details to
        # connect_info, so public introspection won't pick up our changes.  Undecided
        # whether this is good or bad...

        my $storage         = $rsrc->storage;
        my $on_connect_call = $storage->_dbic_connect_attributes->{on_connect_call};

        # Parse on_connect_call to make sure we can add to it
        my $ref = defined $on_connect_call && ref $on_connect_call;
        unless ($on_connect_call) {
            $on_connect_call = \@post_connection_details;
        }
        elsif  (!$ref) {
            $on_connect_call = [ [ do_sql => $on_connect_call ], @post_connection_details ];
        }
        elsif  ($ref eq 'ARRAY') {
            # Double-check that we're not repeating ourselves by inspecting the array for
            # our own statements.
            @$on_connect_call = grep {
                my $e = $_;
                !(  # exclude any of ours
                    $e && ref $e && ref $e eq 'ARRAY' && @$e == 2 &&
                    $e->[0] && !ref $e->[0] && $e->[0] eq 'do_sql' &&
                    $e->[1] && !ref $e->[1] && (any { $e->[1] eq $_ } @stmts)
                );
            } @$on_connect_call;

            my $first_occ = $on_connect_call->[0];
            if ($first_occ && ref $first_occ && ref $first_occ eq 'ARRAY') {
                $on_connect_call = [ @$on_connect_call, @post_connection_details ];
            }
            else {
                $on_connect_call = [ $on_connect_call, @post_connection_details ];
            }
        }
        elsif  ($ref eq 'CODE') {
            $on_connect_call = [ $on_connect_call, @post_connection_details ];
        }
        else {
            die "Illegal reftype $ref for on_connect_call connection attribute!";
        }

        # Set the new options on the relevant attributes that Storage::DBI->connect_info touches.
        $storage->_dbic_connect_attributes->{on_connect_call} = $on_connect_call;
        $storage->on_connect_call($on_connect_call);
    }
    else {
        ### DBIx::Connector::Retry (via DBI Callbacks)

        my $conn      = $self->dbi_connector;
        my $dbi_attrs = $conn->connect_info->[3];

        # Playing with refs, so no need to re-set connect_info
        $conn->connect_info->[3] = $dbi_attrs = {} unless $dbi_attrs;

        # Make sure the basic settings are sane
        $dbi_attrs->{AutoCommit} = 1;
        $dbi_attrs->{RaiseError} = 1;

        # Add the DBI callback
        my $callbacks  = $dbi_attrs->{Callbacks} //= {};
        my $package_re = quotemeta(__PACKAGE__.'::_dbi_connected_callback');

        my $ref = defined $callbacks->{connected} && ref $callbacks->{connected};
        unless ($callbacks->{connected}) {
            $callbacks->{connected} = set_subname '_dbi_connected_callback' => sub {
                shift->do($_) for @stmts;
                return;
            };
        }
        elsif (!$ref || $ref ne 'CODE') {
            die "Illegal reftype $ref for connected DBI Callback!";
        }
        elsif (subname($callbacks->{connected}) =~ /^$package_re/) {  # allow for *_wrapped below
            # This is one of our callbacks; leave it alone!
        }
        else {
            # This is somebody else's callback; wrap around it
            my $old_coderef = $callbacks->{connected};
            $callbacks->{connected} = set_subname '_dbi_connected_callback_wrapped' => sub {
                my $h = shift;
                $old_coderef->($h);
                $h->do($_) for @stmts;
                return;
            };
        }

        # Add a proper retry_handler
        $conn->retry_handler(sub { $self->_retry_handler(@_) });

        # And max_attempts.  XXX: Maybe they actually wanted 10 and not just the default?
        $conn->max_attempts($DEFAULT_MAX_ATTEMPTS) if $conn->max_attempts == 10;
    }

    # Go ahead and run the post-connection statements for this session
    $dbh->{AutoCommit} = 1;
    $dbh->{RaiseError} = 1;
    $dbh->do($_) for @stmts;
}

#pod =head1 CONSTRUCTORS
#pod
#pod See L</ATTRIBUTES> for information on what can be passed into these constructors.
#pod
#pod =head2 new
#pod
#pod     my $online_ddl = DBIx::OnlineDDL->new(...);
#pod
#pod A standard object constructor. If you use this constructor, you will need to manually
#pod call L</execute> to execute the DB changes.
#pod
#pod You'll probably just want to use L</construct_and_execute>.
#pod
#pod =head2 construct_and_execute
#pod
#pod     my $online_ddl = DBIx::OnlineDDL->construct_and_execute(...);
#pod
#pod Constructs a DBIx::OnlineDDL object and automatically calls each method step, including
#pod hooks.  Anything passed to this method will be passed through to the constructor.
#pod
#pod Returns the constructed object, post-execution.  This is typically only useful if you want
#pod to inspect the attributes after the process has finished.  Otherwise, it's safe to just
#pod ignore the return and throw away the object immediately.
#pod
#pod =cut

sub construct_and_execute {
    my $class      = shift;
    my $online_ddl = $class->new(@_);

    $online_ddl->execute;

    return $online_ddl;
}

#pod =head1 METHODS
#pod
#pod =head2 Step Runners
#pod
#pod =head3 execute