File Coverage

blib/lib/File/Trash/FreeDesktop.pm

Criterion	Covered	Total	%
statement	202	227	88.9
branch	93	128	72.6
condition	19	36	52.7
subroutine	19	19	100.0
pod	7	7	100.0
total	340	417	81.5

package File::Trash::FreeDesktop;

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

use Fcntl;
use File::Util::Test qw(file_exists l_abs_path);

our $AUTHORITY = 'cpan:PERLANCAR'; # AUTHORITY
our $DATE = '2023-11-21'; # DATE
our $DIST = 'File-Trash-FreeDesktop'; # DIST
our $VERSION = '0.207'; # 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,
            (
                $self->{home_only} ? () : (map { (
                    "$_/.Trash-$>",
                    "$_/tmp/.Trash-$>",
                    "$_/.Trash/$>",
                    "$_/tmp/.Trash/$>",
                ) } @mp)
            )
        );

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

sub _parse_trashinfo {
    require Time::Local;

    # we use regex parsing instead of INI to be simpler
    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;
  PARSE_DELETIONDATE: {
        $content =~ /^DeletionDate=(\d{4})-?(\d{2})-?(\d{2})T(\d\d):(\d\d):(\d\d)$/m
            or do { warn "No/invalid DeletionDate line for path $res->{path}"; last PARSE_DELETIONDATE };
        $res->{deletion_date} = Time::Local::timelocal(
            $6, $5, $4, $3, $2-1, $1-1900)
            or do { warn "Invalid deletion date: $1-$2-$3T$4-$5-$6 when parsing trashinfo for path $res->{path}"; last PARSE_DELETIONDATE };
    }
    $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;
    my ($path_wc_re, $filename_wc_re);
  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 };
      ENTRY:
        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 $parse_res = $self->_parse_trashinfo($content);
            die "Can't parse trash info file $e: $parse_res" unless ref($parse_res);

          FILTER: {
                if (defined $opts->{path}) {
                    next ENTRY unless $parse_res->{path} eq $opts->{path};
                }
                if (defined $opts->{path_wildcard}) {
                    unless (defined $path_wc_re) {
                        require String::Wildcard::Bash;
                        $path_wc_re = String::Wildcard::Bash::convert_wildcard_to_re({globstar=>1}, $opts->{path_wildcard});
                    }
                    next ENTRY unless $parse_res->{path} =~ $path_wc_re;
                }
                if (defined $opts->{path_re}) {
                    next ENTRY unless $parse_res->{path} =~ $opts->{path_re};
                }
              FILTER_FILENAME: {
                    (my $filename = $parse_res->{path}) =~ s!.+/!!;
                    if (defined $opts->{filename}) {
                        next ENTRY unless $filename eq $opts->{filename};
                    }
                    if (defined $opts->{filename_wildcard}) {
                        unless (defined $filename_wc_re) {
                            require String::Wildcard::Bash;
                            $filename_wc_re = String::Wildcard::Bash::convert_wildcard_to_re({globstar=>1}, $opts->{filename_wildcard});
                        }
                        next ENTRY unless $filename =~ $filename_wc_re;
                    }
                    if (defined $opts->{filename_re}) {
                        next ENTRY unless $filename =~ $opts->{filename_re};
                    }
                } # FILTER_FILENAME
            } # FILTER

            my $afile = "$trash_dir/files/$e"; $afile =~ s/\.trashinfo\z//;
            if (defined $opts->{mtime}) {
                my @st = lstat($afile);
                next ENTRY unless !@st || $st[9] == $opts->{mtime};
            }
            if (defined $opts->{suffix}) {
                next ENTRY unless $afile =~ /\.\Q$opts->{suffix}\E\z/;
            }
            $parse_res->{trash_dir} = $trash_dir;
            $e =~ s/\.trashinfo//; $parse_res->{entry} = $e;
            push @res, $parse_res;
        }
    }

    @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_dir) = @_;

    $opts->{path} //= $file0;
    my @ct = $self->list_contents($opts, $trash_dir);

  ENTRY:
    for my $e (@ct) {
        if (file_exists($e->{path})) {
            if ($opts->{on_target_exists} eq 'ignore') {
                next ENTRY;
            } else {
                die "Restore target already exists: $e->{path}";
            }
        }
        my $afile = l_abs_path($e->{path});
        my $ifile = "$e->{trash_dir}/info/$e->{entry}.trashinfo";
        my $tfile = "$e->{trash_dir}/files/$e->{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, $opts, $trash_dir) = @_;

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

sub erase {
    my $self = shift;
    my $opts = ref($_[0]) eq 'HASH' ? {%{shift(@_)}} : {};
    my ($file, $trash_dir) = @_;
    $opts->{filename} //= $file;

    # make sure user specifies at least one of filename
    # option/$file/filename_wildcard/filename_re/path/path_wildcard/path_re.
    # specifying no files will include all entries. for that user should be more
    # explicit and call empty().
    unless (defined $file or
            defined $opts->{filename} or
            defined $opts->{filename_wildcard} or
            defined $opts->{filename_re} or
            defined $opts->{path} or
            defined $opts->{path_wildcard} or
            defined $opts->{path_re}) {
        die "Please specify at least file/filename/filename_wildcard/filename_re ".
            "or path/path_wildcard/path_re";
    }
    $self->_erase($opts, $trash_dir);
}

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

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

1;
# ABSTRACT: Trash files

__END__