view release on metacpan or  search on metacpan

lib/App/Greple/update.pm  view on Meta::CPAN

Copyright 2022-2026 Kazumasa Utashiro.

This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself.

=cut

package App::Greple::update;
use v5.24;
use warnings;
use experimental 'refaliasing';

our $VERSION = '1.05';

use utf8;
use open IO => ':utf8';

use Exporter 'import';
our @EXPORT      = qw(
    &update_initialize
    &update_begin
    &update_diff
    &update_divert
    &update_file
    );
our %EXPORT_TAGS = ( );
our @EXPORT_OK   = qw();

use Carp;
use Encode;
use Data::Dumper;
use App::Greple::Common;
use Text::ParseWords qw(shellwords);
use Getopt::EX::Config;

our $debug = 0;

my $config = Getopt::EX::Config->new(
    remember      => 1,
    diff_command  => "diff -u",
    update_suffix => '',
    with_backup   => undef,
    diff_context  => '',
);

# The builtin options in __DATA__ and the config set the same values.
\our $remember_data      = \$config->{remember};
\our $opt_update_diffcmd = \$config->{diff_command};
\our $opt_suffix         = \$config->{update_suffix};
\our $opt_backup         = \$config->{with_backup};
\our $opt_U              = \$config->{diff_context};

my $current_file;
my $contents;
my @update_diffcmd;

sub debug {
    $debug = 1;
}

sub update_initialize {
    @update_diffcmd = shellwords $opt_update_diffcmd;
    if ($opt_U ne '') {
	@update_diffcmd = ('diff', "-U$opt_U");
    }
    if (defined $opt_backup) {
	# no value: "" from --with-backup, 1 from config(with_backup)
	$opt_suffix = $opt_backup =~ /^1?$/ ? '.bak' : $opt_backup;
    }
}

sub update_begin {
    my %arg = @_;
    $current_file = delete $arg{&FILELABEL} or die;
    $contents = $_ if $remember_data;
}

#
# define &divert_stdout and &recover_stdout
#
{
    my $divert;
    my $bufref;

    sub divert_stdout {
	$bufref = shift;
	return if $divert;
	require IO::Divert;
	$divert = IO::Divert->new(autoprint => 0);
    }

    sub recover_stdout {
	$divert or return;
	$$bufref = $divert->cancel->content;
	undef $divert;
	1;
    }
}

use List::Util qw(first);

sub update_diff {
    my $orig = $current_file;
    my $fh;
    state $fdpath = do {
	my $fd = DATA->fileno;
	first { -r "$_/$fd" } qw( /dev/fd /proc/self/fd );
    };

    if ($fdpath and $remember_data) {
	use IO::File;
	use Fcntl;
	$fh = IO::File->new_tmpfile or die "new_tmpfile: $!\n";
	$fh->binmode(':encoding(utf8)');
	my $fd = $fh->fcntl(F_GETFD, 0) or die "fcntl F_GETFD: $!\n";
	$fh->fcntl(F_SETFD, $fd & ~FD_CLOEXEC) or die "fcntl F_SETFD: $!\n";
	$fh->printflush($contents);
	$fh->seek(0, 0);
	$orig = sprintf "%s/%d", $fdpath, $fh->fileno;
    }

    @update_diffcmd or confess "Empty diff command";
    exec @update_diffcmd, $orig, "-";
    die "exec: $!\n";
}

my $divert_buffer;

sub update_divert {
    my %arg = @_;
    my $filename = delete $arg{&FILELABEL};

    $divert_buffer = '';
    divert_stdout(\$divert_buffer);
}

sub update_file {
    my %arg = @_;
    my $filename = delete $arg{&FILELABEL};
    my $newname = '';

    recover_stdout() or die;
    return if $arg{discard};
    $divert_buffer = decode 'utf8', $divert_buffer;

    return if $divert_buffer eq $_;
    return if $divert_buffer eq '';

    if (my $suffix = $opt_suffix) {
	$newname = $filename . $suffix;
	for (my $i = 1; -f $newname; $i++) {
	    $newname = $filename . $suffix . "_$i";
	}
    }

    my $create = do {
	if ($arg{replace}) {
	    if ($newname ne '') {
		warn "rename $filename -> $newname\n";
		rename $filename, $newname or die "rename: $!\n";
		die if -f $filename;
	    } else {
		warn "overwrite $filename\n";
	    }
	    $filename;
	} else {
	    warn "create $newname\n";
	    $newname;
	}
    };

    open my $fh, ">", $create or die "open: $create $!\n";
    $fh->print($divert_buffer);
    $fh->close;
}

1;

__DATA__

builtin diff-command=s $opt_update_diffcmd
builtin update-suffix=s      $opt_suffix
builtin diff-context|U=i     $opt_U
builtin remember!     $remember_data
builtin with-backup:s $opt_backup

option default \
	--prologue update_initialize \
	--begin    update_begin

expand ++dump --all -h --color=never --no-newline --no-line-number
option --update::diff    ++dump --of &update_diff
option --update::create  ++dump --begin update_divert --end update_file() --update-suffix=.new
option --update::update  ++dump --begin update_divert --end update_file(replace)
option --update::discard        --begin update_divert --end update_file(discard)

option --diff    --update::diff