File Coverage

blib/lib/File/Trash/FreeDesktop.pm

Criterion	Covered	Total	%
statement	181	202	89.6
branch	74	108	68.5
condition	10	12	83.3
subroutine	19	19	100.0
pod	7	7	100.0
total	291	348	83.6

package File::Trash::FreeDesktop;

use 5.010001;
use strict;
use warnings;
use Log::ger;

use Fcntl;
use File::MoreUtil qw(file_exists l_abs_path);

our $AUTHORITY = 'cpan:PERLANCAR'; # AUTHORITY
our $DATE = '2022-05-06'; # DATE
our $DIST = 'File-Trash-FreeDesktop'; # DIST
our $VERSION = '0.200'; # VERSION

sub new {
    require File::HomeDir::FreeDesktop;

    my ($class, %opts) = @_;

    my $home = File::HomeDir::FreeDesktop->my_home
        or die "Can't get homedir, ".
            "probably not a freedesktop-compliant environment?";
    $opts{_home} = l_abs_path($home);

    bless \%opts, $class;
}

sub _mk_trash {
    my ($self, $trash_dir) = @_;
    for ("", "/files", "/info") {
        my $d = "$trash_dir$_";
        unless (-d $d) {
            log_trace("Creating directory %s ...", $d);
            mkdir $d, 0700 or die "Can't mkdir $d: $!";
        }
    }
}

sub _home_trash {
    my ($self) = @_;
    "$self->{_home}/.local/share/Trash";
}

sub _mk_home_trash {
    my ($self) = @_;
    for (".local", ".local/share") {
        my $d = "$self->{_home}/$_";
        unless (-d $d) {
            mkdir $d or die "Can't mkdir $d: $!";
        }
    }
    $self->_mk_trash("$self->{_home}/.local/share/Trash");
}

sub _select_trash {
    require Sys::Filesystem::MountPoint;

    my ($self, $file0) = @_;
    file_exists($file0) or die "File doesn't exist: $file0";
    my $afile = l_abs_path($file0);

    # since path_to_mount_point resolves symlink (sigh), we need to remove the
    # leaf. otherwise: /mnt/sym -> / will cause mount point to become / instead
    # of /mnt
    my $afile2 = $afile; $afile2 =~ s!/[^/]+\z!! if (-l $file0);
    my $file_mp = Sys::Filesystem::MountPoint::path_to_mount_point($afile2);

    if ($ENV{PERL_FILE_TRASH_FREEDESKTOP_DEBUG}) {
        log_trace "File's mountpoint for file $file0 is $file_mp";
    }

    $self->{_home_mp} //= Sys::Filesystem::MountPoint::path_to_mount_point(
        $self->{_home});

    if ($ENV{PERL_FILE_TRASH_FREEDESKTOP_DEBUG}) {
        log_trace "Home mountpoint for file $file0 is $self->{_home_mp}";
    }

    # try home trash
    if ($self->{_home_mp} eq $file_mp) {
        my $trash_dir = $self->_home_trash;
        log_trace("Selected home trash for %s = %s", $afile, $trash_dir);
        $self->_mk_home_trash;
        return $trash_dir;
    }

    # try file's mountpoint or mountpoint + "/tmp" (try "/tmp" first if /)
    my $suggestion = '';
    for my $dir ($file_mp eq '/' ?
                     ("/tmp", "/") : ($file_mp, "$file_mp/tmp")) {
        unless (-w $dir) {
            if ($ENV{PERL_FILE_TRASH_FREEDESKTOP_DEBUG}) {
                log_trace "Directory $dir is not writable, skipped";
            }
            $suggestion = ", try making directory $dir writable?";
            next;
        }
        if ($dir ne $file_mp) {
            my $mp = Sys::Filesystem::MountPoint::path_to_mount_point($dir);
            next unless $mp eq $file_mp;
        }
        my $trash_dir = ($dir eq "/" ? "" : $dir) . "/.Trash-$>";
        log_trace("Selected trash for %s = %s", $afile, $trash_dir);
        $self->_mk_trash($trash_dir);
        return $trash_dir;
    }

    die "Can't find suitable trash dir$suggestion";
}

sub list_trashes {
    require List::Util;
    require Sys::Filesystem;

    my ($self) = @_;

    my $sysfs = Sys::Filesystem->new;
    my @mp = $sysfs->filesystems;

    my @res = map { l_abs_path($_) }
        grep {-d} (
            $self->_home_trash,
            (map { (
                "$_/.Trash-$>",
                "$_/tmp/.Trash-$>",
                "$_/.Trash/$>",
                "$_/tmp/.Trash/$>",
                ) } @mp)
        );

    List::Util::uniq(@res);
}

sub _parse_trashinfo {
    require Time::Local;

    my ($self, $content) = @_;
    $content =~ /\A\[Trash Info\]/m or return "No header line";
    my $res = {};
    $content =~ /^Path=(.+)/m or return "No Path line";
    $res->{path} = $1;
    $content =~ /^DeletionDate=(\d{4})-?(\d{2})-?(\d{2})T(\d\d):(\d\d):(\d\d)$/m
        or return "No/invalid DeletionDate line";
    $res->{deletion_date} = Time::Local::timelocal(
        $6, $5, $4, $3, $2-1, $1-1900)
        or return "Invalid date: $1-$2-$3T$4-$5-$6";
    $res;
}

sub list_contents {
    my $self = shift;

    my $opts;
    if (ref($_[0]) eq 'HASH') {
        $opts = shift;
    } else {
        $opts = {};
    }
    my ($trash_dir0) = @_;

    my @trash_dirs = $trash_dir0 ? ($trash_dir0) : ($self->list_trashes);
    my @res;
  L1:
    for my $trash_dir (@trash_dirs) {
        #next unless -d $trash_dir;
        #next unless -d "$trash_dir/info";
        opendir my($dh), "$trash_dir/info"
            or do { warn "Can't read trash info dir $trash_dir/info: $!";next };
        for my $e (readdir $dh) {
            next unless $e =~ /\.trashinfo$/;
            local $/;
            my $ifile = "$trash_dir/info/$e";
            open my($fh), "<", $ifile
                or die "Can't open trash info file $e: $!";
            my $content = <$fh>;
            close $fh;
            my $pres = $self->_parse_trashinfo($content);
            die "Can't parse trash info file $e: $pres" unless ref($pres);
            if (defined $opts->{search_path}) {
                next unless $pres->{path} eq $opts->{search_path};
            }
            my $afile = "$trash_dir/files/$e"; $afile =~ s/\.trashinfo\z//;
            if (defined $opts->{mtime}) {
                my @st = lstat($afile);
                next unless !@st || $st[9] == $opts->{mtime};
            }
            if (defined $opts->{suffix}) {
                next unless $afile =~ /\.\Q$opts->{suffix}\E\z/;
            }
            $pres->{trash_dir} = $trash_dir;
            $e =~ s/\.trashinfo//; $pres->{entry} = $e;
            push @res, $pres;
            last L1 if defined $opts->{search_path};
        }
    }

    @res = sort {
        $a->{deletion_date} <=> $b->{deletion_date} ||
        $a->{entry} cmp $b->{entry}
    } @res;

    @res;
}

sub trash {
    my $self = shift;
    my $opts;
    if (ref($_[0]) eq 'HASH') {
        $opts = shift;
    } else {
        $opts = {};
    }
    $opts->{on_not_found} //= 'die';
    my ($file0) = @_;

    unless (file_exists $file0) {
        if ($opts->{on_not_found} eq 'ignore') {
            return undef; ## no critic: Subroutines::ProhibitExplicitReturnUndef
        } else {
            die "File does not exist: $file0";
        }
    }
    my $afile = l_abs_path($file0);
    my $trash_dir = $self->_select_trash($afile);

    # try to create info/NAME first
    my $name0 = $afile; $name0 =~ s!.*/!!; $name0 = "WTF" unless length($name0);
    my $name;
    my $fh;
    my $i = 1; my $limit = defined($opts->{suffix}) ? 1 : 1000;
    my $tinfo;
    while (1) {
        $name = $name0 . (defined($opts->{suffix}) ? ".$opts->{suffix}" :
                              ($i > 1 ? ".$i" : ""));
        $tinfo = "$trash_dir/info/$name.trashinfo";
        last if sysopen($fh, $tinfo, O_WRONLY | O_EXCL | O_CREAT);
        die "Can't create trash info file $name.trashinfo in $trash_dir: $!"
            if $i >= $limit;
        $i++;
    }
    my $tfile = "$trash_dir/files/$name";

    my @t = localtime();
    my $ts = sprintf("%04d%02d%02dT%02d:%02d:%02d",
                     $t[5]+1900, $t[4]+1, $t[3], $t[2], $t[1], $t[0]);
    syswrite($fh, "[Trash Info]\nPath=$afile\nDeletionDate=$ts\n");
    close $fh or die "Can't write trash info for $name in $trash_dir: $!";

    log_trace("Trashing %s -> %s ...", $afile, $tfile);
    unless (rename($afile, $tfile)) {
        unlink "$trash_dir/info/$name.trashinfo";
        die "Can't rename $afile to $tfile: $!";
    }

    $tfile;
}

sub recover {
    my $self = shift;
    my $opts;
    if (ref($_[0]) eq 'HASH') {
        $opts = shift;
    } else {
        $opts = {};
    }
    $opts->{on_not_found}     //= 'die';
    $opts->{on_target_exists} //= 'die';
    my ($file0, $trash_dir0) = @_;

    if (file_exists($file0)) {
        if ($opts->{on_target_exists} eq 'ignore') {
            return 0;
        } else {
            die "Restore target already exists: $file0";
        }
    }
    my $afile = l_abs_path($file0);

    my @res = $self->list_contents({
        search_path => $afile,
        mtime       => $opts->{mtime},
        suffix      => $opts->{suffix},
    }, $trash_dir0);
    unless (@res) {
        if ($opts->{on_not_found} eq 'ignore') {
            return 0;
        } else {
            die "File not found in trash: $file0";
        }
    }

    my $trash_dir = $res[0]{trash_dir};
    my $ifile = "$trash_dir/info/$res[0]{entry}.trashinfo";
    my $tfile = "$trash_dir/files/$res[0]{entry}";
    log_trace("Recovering from trash %s -> %s ...", $tfile, $afile);
    unless (rename($tfile, $afile)) {
        die "Can't rename $tfile to $afile: $!";
    }
    unlink($ifile);
}

sub _erase {
    require File::Remove;

    my ($self, $file0, $trash_dir) = @_;
    my $afile = defined($file0) ? l_abs_path($file0) : undef;

    my @ct = $self->list_contents({search_path=>$afile}, $trash_dir);

    my @res;
    for (@ct) {
        my $f = "$_->{trash_dir}/info/$_->{entry}.trashinfo";
        unlink $f or die "Can't remove $f: $!";
        # XXX File::Remove interprets wildcard, what if filename contains
        # wildcard?
        File::Remove::remove(\1, "$_->{trash_dir}/files/$_->{entry}");
        push @res, $_->{path};
    }
    @res;
}

sub erase {
    my ($self, $file, $trash_dir) = @_;

    die "Please specify file" unless defined $file;
    $self->_erase($file, $trash_dir);
}

# XXX currently empty calls _erase, which parses .trashinfo files. this is
# useless overhead.
sub empty {
    my ($self, $trash_dir) = @_;

    $self->_erase(undef, $trash_dir);
}

1;
# ABSTRACT: Trash files

__END__