view release on metacpan or  search on metacpan

lib/DBIx/QuickDB/Pool.pm  view on Meta::CPAN

};

sub import {
    my $class  = shift;
    my %params = @_;

    $params{library} ||= caller;

    my $inst = $class->new(%params);

    $inst->export();
}

sub init {
    my $self = shift;

    croak "'cache_dir' is a required_attribute" unless $self->{+CACHE_DIR};

    croak "'cache_dir' must point to an existing directory"
        unless -d $self->{+CACHE_DIR};

    croak "'$self->{+INSTANCE_DIR}' must be an existing directory"
        if $self->{+INSTANCE_DIR} && !-d $self->{+INSTANCE_DIR};

    $self->{+LIBRARY} //= caller(1);

    $self->{+VERBOSE}          //= 0;
    $self->{+PURGE_OLD}        //= 0;
    $self->{+UPDATE_CHECKSUMS} //= 1;

    $self->{+DATABASES} //= {};
}

# Remove a disposable database tree, or move it out of the canonical cache path
# when Windows still refuses the removal after retries. Returning true means the
# canonical path is clear and safe to rebuild; clear_old_cache() reclaims the
# quarantine on a later pass, and it can never be mistaken for a valid entry.
sub _remove_or_quarantine {
    my ($self, $dir) = @_;

    my $stale = remove_tree_or_quarantine($dir);
    return 0 unless defined $stale;

    $self->diag("$$ Quarantined stale database directory '$dir' as '$stale'")
        if length $stale;
    return 1;
}

sub clear_old_cache {
    my $self = shift;
    my ($age) = @_;

    my $dir = $self->{+CACHE_DIR};

    opendir(my $dh, $dir) or die "Could not open cache dir '$dir': $!";
    for my $name (readdir($dh)) {
        my $full = "$dir/$name";

        # Quarantines sit outside the canonical cache path (see
        # _remove_or_quarantine). Retry their removal on every pass: the
        # transient Windows file lock that blocked deletion may have cleared.
        if ($name =~ m/\.STALE-/) {
            remove_tree_robust($full) if -d $full;
            next;
        }

        # A live cache entry is a bare directory name. Its marker files
        # ("$name.lock", "$name.READY") do contain dots and are handled
        # through their entry, never scanned directly.
        next if $name =~ m/\./;

        next unless -d $full;

        my $file = "$full/cloned";
        next unless -f $file;

        open(my $fh, '<', $file) or next;
        my $stamp = <$fh>;
        close($fh);
        $stamp = '' unless defined $stamp;
        chomp($stamp);

        # Time::HiRes values written by older releases can contain a decimal
        # comma under the Windows process locale (for example 1785633742,27439).
        # Cache expiry needs only whole seconds, so accept either historical
        # fractional spelling and reduce it to a locale-independent integer. A
        # damaged stamp is treated as infinitely old so it is reclaimed rather
        # than pinning an unusable clone in the cache forever.
        $stamp =~ s/[.,]\d+\z//;
        $stamp = 0 unless $stamp =~ /^\d+\z/;

        next unless $age <= (time - $stamp);

        eval {
            # An expired SQLite source may still have DBI handles retained by
            # application/test code. On Windows those handles prevent unlinking
            # the database file. Close every matching handle before removal.
            disconnect_dbi_handles($full);

            # If removal remains blocked, moving the tree out of its canonical
            # path keeps a later build from seeing partially-removed SQLite
            # schema/data. Either way, invalidate the external markers: expiry
            # was explicitly requested, and build_db() will refuse to build on
            # any stubborn tree that could not be quarantined.
            $self->_remove_or_quarantine($full);
            unlink("$full.lock") if -e "$full.lock";
            unlink("$full.READY") if -e "$full.READY";
            1;
        } or warn $@;
    }
}

sub export {
    my $self = shift;

    my $library = $self->{+LIBRARY};

    my $qdb    = sub { $self };
    my $build  = sub { $self->add_db(@_, caller => [caller()]) };
    my $db     = sub { $self->fetch_db(@_, caller => [caller()]) };
    my $driver = sub { $self->add_driver(@_, caller => [caller()]) };

    no strict 'refs';
    *{"$library\::QDB_POOL"} = $qdb;
    *{"$library\::driver"}   = $driver;
    *{"$library\::build"}    = $build;
    *{"$library\::db"}       = $db;

    push @{"$library\::EXPORT_OK"} => 'db';
}

sub throw {
    my $self = shift;
    my ($msg, %params) = @_;
    my $caller = $params{caller} || [caller(1)];
    die "$msg at $caller->[1] line $caller->[2].\n";
}

sub alert {
    my $self = shift;
    my ($msg, %params) = @_;
    my $caller = $params{caller} || [caller(1)];
    warn "$msg at $caller->[1] line $caller->[2].\n";
}

sub diag {
    my $self = shift;
    my ($msg, %params) = @_;
    my $show = $self->{+VERBOSE} || $self->{+SHOW_DIAG};
    return unless $show;

    # Only append caller info when asked
    if (my $caller = $params{caller}) {
        $msg .= " at $caller->[1] line $caller->[2].";
    }

    if ($show > 1) {
        print STDERR "$msg\n";
    }
    else {