view release on metacpan or  search on metacpan

lib/App/Greple/xlate/Cache.pm  view on Meta::CPAN

    }
    if (my $seed = $obj->seed) {
        if (%{$obj->saved}) {
            warn "$seed: seed ignored (cache exists)\n";
        } elsif (CORE::open my $fh, $seed) {
            my $data = do { local $/; <$fh> };
            if ($data ne '') {
                $obj->load_data($data);
                $obj->seeded = 1;
                warn "seed cache from $seed\n";
            }
        } else {
            warn "$seed: $!\n";
        }
    }
    $obj;
}

sub load_data {
    my($obj, $data) = @_;
    my $json = &json->decode($data);
    if (ref $json eq 'HASH') {
        $obj->{saved} = $json;
        $obj->{saved_order} = [];   # legacy format: no order info
    } elsif (ref $json eq 'ARRAY') {
        $obj->{saved} = +{ map @{$_}[0,1], @$json };
        $obj->{saved_order} = [ map $_->[0], @$json ];
    } else {
        die "unexpected json data.";
    }
    $obj->{old_pos} = undef;    # invalidate memoized position map
}

sub old_size {
    my $obj = shift;
    scalar @{$obj->saved_order};
}

sub old_position {
    my($obj, $key) = @_;
    my $pos = $obj->{old_pos} //= do {
        my $order = $obj->saved_order;
        +{ map { $order->[$_] => $_ } 0 .. $#$order };
    };
    $pos->{$key};
}

sub old_entries_slice {
    my($obj, $lo, $hi) = @_;
    my $order = $obj->saved_order;
    $lo = 0 if $lo < 0;
    $hi = $#$order if $hi > $#$order;
    my @out;
    for my $k (@$order[$lo .. $hi]) {
        my $v = $obj->saved->{$k} // $obj->current->{$k};
        push @out, [ $k, $v ] if defined $v;
    }
    @out;
}

sub update {
    my $obj = shift;
    return if $obj->readonly;
    my $file = $obj->name || return;
    if (not $obj->force_update and $obj->updated == 0) {
        # accumulate: nothing changed, disk content is already right.
        # otherwise: return only when there is nothing to purge.
        return if not $obj->seeded and ($obj->accumulate or %{$obj->saved} == 0);
    }
    if ($obj->accumulate) {
        # POD promises unused entries survive: adopt them unconditionally
        for my $k (@{$obj->saved_order}, sort keys %{$obj->saved}) {
            next if $obj->accessed->{$k};
            defined(my $v = delete $obj->saved->{$k}) or next;
            $obj->current->{$k} //= $v;
            $obj->access($k);
        }
    }
    # A key is "used" when it was accessed this run, even if its value
    # was never FETCHed (e.g. the run died before the output callback
    # could read it back).  Adopt such entries so they survive.
    for my $k (grep { $obj->accessed->{$_} } keys %{$obj->saved}) {
        $obj->current->{$k} //= delete $obj->saved->{$k};
    }
    while (my($k, $v) = each %{$obj->current}) {
        delete $obj->current->{$k} if not defined $v;
    }
    if (not %{$obj->current}) {
        # A seeded cache may end its run without any access (e.g.
        # --xlate-cache=create dies right after setup); persist the
        # seed content instead of leaving the created file empty.
        return $obj->checkpoint if $obj->seeded;
        return;
    }
    my $json_obj //= &json; # this is necessary to be called from DESTROY
    if (CORE::open my $fh, '>', $file) {
        my $data = $obj->format eq 'list' ? $obj->list_data : $obj->hash_data;
        my $json = $json_obj->encode($data);
        print $fh $json;
        warn "write cache to $file\n";
    } else {
        warn "$file: $!\n";
    }
}

##
## Write out the merged state (saved and current, current wins)
## WITHOUT purging unused entries.  Called after each translation
## batch so that an interrupted run does not lose paid API results.
## The final write (update) keeps the purging semantics.
##
## Keys stored without going through the tie interface (no access())
## are not visible to checkpoint.
##
sub checkpoint {
    my $obj = shift;
    return if $obj->readonly;
    my $file = $obj->name || return;
    my(@list, %done);
    for my $key (@{$obj->saved_order}) {
        next if $done{$key}++;