view release on metacpan or  search on metacpan

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

            $obj->set(mesh $a, $b);
        } else {
            my $c = $obj->current->{$a} //= delete $obj->saved->{$a};
            if (not defined $c or $c ne $b) {
                $obj->current->{$a} = $b;
                $obj->updated++;
            }
        }
    } @_;
    $obj;
}

sub json {
    JSON->new->utf8->canonical->pretty;
}

sub open {
    my $obj = shift;
    my $file = $obj->name || return;
    if ($obj->clear and not $obj->readonly) {
        warn "created $file\n" unless -f $file;
        CORE::open my $fh, '>', $file or die "$file: $!\n";
        print $fh "{}\n";
    }
    $obj->{saved} = {};
    $obj->{saved_order} = [];
    if (CORE::open my $fh, $file) {
        my $data = do { local $/; <$fh> };
        $obj->load_data($data) if $data ne '';
        warn "read cache from $file\n";
    }
    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.