#!/usr/bin/perl

# Copyright (C) 2002 Maik Schreiber
# Distributed under the terms of the GNU General Public License v2 or later
# $Header: /cvsroot/perltrash/perltrash.pl,v 1.4 2002/12/14 12:01:12 mickey Exp $

use Fcntl ':mode';
use File::Basename;
use File::Copy;
use File::Spec::Functions qw(:ALL);
use File::stat;
use File::Temp qw(:mktemp);
use POSIX 'strftime';


our $version = '0.3';


sub print_message
{
  print 'perltrash: ' . shift() . "\n";
}

sub print_error
{
  print STDERR 'perltrash: error: ' . shift() . "\n";
}


sub get_dir_entries
{
  my $dir = shift();
  my @entries;
  my $entry;
  my @newentries;

  if (opendir(DIR, $dir))
  {
    @entries = readdir(DIR);
    closedir(DIR);

    foreach $entry (@entries)
    {
      if ($entry !~ /^[\.]{1,2}$/)
      {
        push(@newentries, catdir($dir, $entry));
      }
    }
  }
  else
  {
    print_error('couldn\'t open directory ' . $dir . ': ' . $!);
  }

  return @newentries;
}


sub get_size
{
  my $file = shift();
  my $st;
  my $size = 0;

  $st = lstat($file);
  if ($st)
  {
    if (S_ISDIR($st->mode))
    {
      @entries = get_dir_entries($file);
      foreach $entry (@entries)
      {
        $size += get_size($entry);
      }
    }
    else
    {
      $size = $st->size;
    }

    return $size;
  }

  print_error('couldn\'t stat ' . $file . ': ' . $!);
  return -1;
}

sub get_sizes
{
  my @files = @_;
  my $file;
  my $allsize = 0;
  my $size;

  foreach $file (@files)
  {
    $file = get_full_path($file);
    $size = get_size($file);
    if ($size >= 0)
    {
      $allsize += $size;
    }
    else
    {
      return -1;
    }
  }

  return $allsize;
}


sub get_full_path
{
  my $file = shift();
  my @relpath;
  my @rootpath = splitdir(rootdir());
  my @path = splitdir($ENV{'PWD'});
  my $relpath_element;
  my $updir = updir();

  $file = canonpath($file);
  @relpath = splitdir($file);

  if (file_name_is_absolute($file))
  {
    @path = @rootpath;
  }

  for $relpath_element (@relpath)
  {
    if ($relpath_element eq $updir)
    {
      if ($#path > $#rootpath)
      {
        pop(@path);
      }
    }
    else
    {
      push(@path, $relpath_element);
    }
  }

  return catdir(@path);
}


sub create_trashdir
{
  my $st;
  my $trashdir = catdir($ENV{'HOME'}, '.perltrash');

  $st = stat($trashdir);
  if ($st)
  {
    if (S_ISDIR($st->mode))
    {
      return 1;
    }

    print_error($trashdir . ' already exists, but is no directory');
    return 0;
  }

  if (mkdir($trashdir))
  {
    return 1;
  }

  print_error($!);
  return 0;
}


sub trash_files
{
  my @files = @_;
  my $limit_size = get_limit('size');
  my $allsize;
  my $file;
  my $rc = 1;
  my $trashdir = catdir($ENV{'HOME'}, '.perltrash');
  my $trashlist = catdir($trashdir, 'trashlist');

  if ($limit_size < 0)
  {
    return 0;
  }

  $allsize = get_sizes(@files);
  if ($allsize < 0)
  {
    return 0;
  }
  if (($allsize > $limit_size) && ($limit_size > 0))
  {
    print_message('size of files exceeds trash can limit, not deleting');
    return 0;
  }

  purge_trashcan($allsize);

  if (open(TRASHLIST, '>>' . $trashlist))
  {
    foreach $file (@files)
    {
      if (trash_file($file, TRASHLIST) == 0)
      {
        $rc = 0;
      }
    }
    close(TRASHLIST);
  }
  else
  {
    print_error('couldn\'t append to ' . $trashlist . ': ' . $!);
    return 0;
  }

  return $rc;
}

sub trash_file
{
  my $file = shift();
  my $trashlist = shift();
  my $trashfile;
  my $size;
  my $trashfiletmpl = catdir($ENV{'HOME'}, '.perltrash', 'perltrash.XXXXXX');

  $file = get_full_path($file);

  $size = get_size($file);
  if ($size >= 0)
  {
    if ($trashfile = mktemp($trashfiletmpl))
    {
      if (move($file, $trashfile) == 0)
      {
        print_error('couldn\'t trash ' . $file . ': ' . $!);
        unlink($trashfile);   # just to make sure...
        return 0;
      }

      # cut leading "perltrash."
      $trashfile = substr(basename($trashfile), 10);

      print $trashlist $trashfile . ';' . time() . ';' . $size . ';' . $file . "\n";

      return 1;
    }

    print_error('couldn\'t generate temporary file name');
  }

  return 0;
}

sub purge_trashcan
{
  my $needsize = shift();
  my $trashdir = catdir($ENV{'HOME'}, '.perltrash');
  my $trashlist = catdir($trashdir, 'trashlist');
  my @entries;
  my @newentries = ();
  my $entry;
  my $limit_size = get_limit('size');
  my $limit_age = get_limit('age');
  my $allsize = 0;
  my $trashfile;
  my $time;
  my $size;
  my $x;
  my $remove_entry;
  my $st;

  if (($limit_size > 0) || ($limit_age > 0))
  {
    if (open(TRASHLIST, $trashlist))
    {
      @entries = <TRASHLIST>;
      close(TRASHLIST);

      @entries = sort({get_time_from_entry($b) <=> get_time_from_entry($a)} @entries);

      foreach $entry (@entries)
      {
        $entry =~ s/[\r\n]//g;
        ($x, $x, $size, $x) = split(/;/, $entry);
        $allsize += $size;
      }

      foreach $entry (@entries)
      {
        $remove_entry = 0;

        $entry =~ s/[\r\n]//g;
        ($trashfile, $time, $size, $x) = split(/;/, $entry);

        if ((($allsize + $needsize) > $limit_size) && ($limit_size > 0))
        {
          $remove_entry = 1;
        }

        if ((((time() - $time) / 1000 / 60 / 60 / 24) > $limit_age) && ($limit_age > 0))
        {
          $remove_entry = 1;
        }

        if ($remove_entry == 1)
        {
          # successful removal flag
          $remove_entry = 0;

          if ($st = lstat(catdir($trashdir, 'perltrash.' . $trashfile)))
          {
            if (S_ISDIR($st->mode))
            {
              if (empty_dir(catdir($trashdir, 'perltrash.' . $trashfile)) == 1)
              {
                if (rmdir(catdir($trashdir, 'perltrash.' . $trashfile)))
                {
                  $remove_entry = 1;
                }
              }
            }
            else
            {
              if (unlink(catdir($trashdir, 'perltrash.' . $trashfile)))
              {
                $remove_entry = 1;
              }
            }
          }

          # removal failed, ignore
          if ($remove_entry == 0)
          {
            push(@newentries, $entry);
          }
        }
        else
        {
          push(@newentries, $entry);
        }
      }
    }
  }

  if (open(TRASHLIST, '>' . $trashlist))
  {
    foreach $entry (@newentries)
    {
      print TRASHLIST $entry . "\n";
    }

    close(TRASHLIST);
  }
  else
  {
    print_error('couldn\'t open ' . $trashlist . ': ' . $!);
  }
}


sub list_trashcan
{
  my @entries = ();
  my $entry;
  my $trashfile;
  my $time;
  my $size;
  my $origin;
  my $type;
  my $allsize = 0;
  my $limit_size = get_limit('size');
  my $limit_age = get_limit('age');
  my $trashdir = catdir($ENV{'HOME'}, '.perltrash');
  my $trashlist = catdir($trashdir, 'trashlist');

  if ($limit_size == 0)
  {
    $limit_size = 'unlimited';
  }
  else
  {
    $limit_size .= ' bytes';
  }

  if ($limit_age == 0)
  {
    $limit_age = 'unlimited';
  }
  else
  {
    $limit_age .= ' days';
  }

  if (open(TRASHLIST, $trashlist))
  {
    @entries = <TRASHLIST>;
    close(TRASHLIST);
  }

  @entries = sort({get_time_from_entry($b) <=> get_time_from_entry($a)} @entries);

  print "ID      Deletion date/time   T Origin\n" .
        "---------------------------------------------------------------------------\n";

  foreach $entry (@entries)
  {
    $entry =~ s/[\r\n]//g;
    ($trashfile, $time, $size, $origin) = split(/;/, $entry);
    if ($st = lstat(catdir($trashdir, 'perltrash.' . $trashfile)))
    {
      if (S_ISREG($st->mode))
      {
        $type = '-';
      }
      elsif (S_ISDIR($st->mode))
      {
        $type = 'd';
      }
      elsif (S_ISCHR($st->mode))
      {
        $type = 'c';
      }
      elsif (S_ISBLK($st->mode))
      {
        $type = 'b';
      }
      elsif (S_ISFIFO($st->mode))
      {
        $type = 'p';
      }
      elsif (S_ISLNK($st->mode))
      {
        $type = 'l';
      }
      elsif (S_ISSOCK($st->mode))
      {
        $type = 's';
      }
      else
      {
        $type = '?';
      }

      print $trashfile . '  ' . strftime('%F %T', localtime($time)) . '  ' .
            $type . ' ' . sprintf("%-46s", $origin) . "\n";

      $allsize += $size;
    }
  }

  print "\nTrash can size: " . $allsize . ' bytes in ' . ($#entries + 1) . " entries\n\n" .
        'Size limit: ' . $limit_size . "\n" .
        'Age limit:  ' . $limit_age . "\n";
}

sub get_time_from_entry
{
  my $entry = shift();
  my $time;
  my $x;

  $entry =~ s/[\r\n]//g;
  ($x, $time, $x, $x) = split(/;/, $entry);

  return $time;
}


sub restore_files
{
  my $into_cwd = shift();
  my @trashfiles = @_;
  my $trashfile;
  my @entries;
  my $entry;
  my @newentries;
  my $rc = 1;
  my $trashlist = catdir($ENV{'HOME'}, '.perltrash', 'trashlist');

  if (open(TRASHLIST, $trashlist))
  {
    @entries = <TRASHLIST>;
    close(TRASHLIST);

    foreach $entry (@entries)
    {
      $entry =~ s/[\r\n]//g;
      push(@newentries, $entry);
    }
    @entries = @newentries;

    foreach $trashfile (@trashfiles)
    {
      if (restore_file($trashfile, $into_cwd, @entries) == 0)
      {
        $rc = 0;
      }
    }
  }
  else
  {
    print_error('trash can is empty');
    return 0;
  }

  return $rc;
}

sub restore_file
{
  my $trashfile = shift();
  my $into_cwd = shift();
  my @entries = @_;
  my $entry;
  my $origin;
  my $x;
  my $st;

  $entry = get_entry($trashfile, @entries);
  if ($entry eq '')
  {
    print_error($trashfile . ': entry not found');
    return 0;
  }

  ($x, $x, $x, $origin) = split(/;/, $entry);
  if ($into_cwd == 1)
  {
    $origin = catdir($ENV{'PWD'}, basename($origin));
  }

  $st = lstat($origin);
  if ($st)
  {
    print_error('couldn\'t restore ' . $trashfile . ' to ' . $origin . ': file exists');
    return 0;
  }

  if (move(catdir($ENV{'HOME'}, '.perltrash', 'perltrash.' . $trashfile), $origin) == 0)
  {
    print_error('couldn\'t restore entry ' . $trashfile . ' to ' . $origin . ': ' . $!);
    return 0;
  }

  remove_from_trashlist($trashfile, @entries);
  return 1;
}

sub get_entry
{
  my $trashfile = shift();
  my @entries = @_;
  my $entry;

  for $entry (@entries)
  {
    if ($entry =~ /^$trashfile;/)
    {
      return $entry;
    }
  }

  return '';
}

sub remove_from_trashlist
{
  my $trashfile = shift();
  my @entries = @_;
  my $entry;

  if (open(TRASHLIST, '>' . catdir($ENV{'HOME'}, '.perltrash', 'trashlist')))
  {
    foreach $entry (@entries)
    {
      if ($entry !~ /^$trashfile;/)
      {
        print TRASHLIST $entry . "\n";
      }
    }

    close(TRASHLIST);

    return 1;
  }

  return 0;
}


sub empty_trashcan
{
  my $rc;

  $rc = empty_dir(catdir($ENV{'HOME'}, '.perltrash'));
  if ($rc == 0)
  {
    print_error('couldn\'t completely empty trash can');
  }

  return $rc;
}

sub empty_dir
{
  my $dir = shift();
  my @entries = get_dir_entries($dir);
  my $entry;
  my $st;
  my $rc = 1;
  my $trashdir = catdir($ENV{'HOME'}, '.perltrash');
  my $limit_file_size = catdir($trashdir, 'limit-size');
  my $limit_file_age = catdir($trashdir, 'limit-age');

  foreach $entry (@entries)
  {
    if ($st = lstat($entry))
    {
      if (S_ISDIR($st->mode))
      {
        if (empty_dir($entry) == 1)
        {
          if (!rmdir($entry))
          {
            print_error('couldn\'t remove ' . $entry . ': ' . $!);
            $rc = 0;
          }
        }
        else
        {
          print_error('couldn\'t remove ' . $entry . ': directory is not empty');
          $rc = 0;
        }
      }
      # don't delete special files
      elsif (($entry ne $limit_file_size) &&
             ($entry ne $limit_file_age))
      {
        if (!unlink($entry))
        {
          print_error('couldn\'t unlink ' . $entry . ': ' . $!);
          $rc = 0;
        }
      }
    }
    else
    {
      print_error('couldn\'t stat ' . $entry . ': ' . $!);
      $rc = 0;
    }
  }

  return $rc;
}


sub set_limit
{
  my $limit_id = shift();
  my $limit = shift();
  my $trashdir = catdir($ENV{'HOME'}, '.perltrash');
  my $limit_file_size = catdir($trashdir, 'limit-size');
  my $limit_file_age = catdir($trashdir, 'limit-age');

  if ($limit_id eq 'size')
  {
    $limit = convert_size_limit($limit);
    if ($limit >= 0)
    {
      if (open(LIMITFILE, '>' . $limit_file_size))
      {
        print LIMITFILE $limit . "\n";
        close(LIMITFILE);

        print 'perltrash: size limit changed to ';
        if ($limit > 0)
        {
          print $limit . " bytes\n";
        }
        else
        {
          print "unlimited\n";
        }

        return 1;
      }

      print_error('couldn\'t open ' . $limit_file_size . ': ' . $!);
    }
  }
  elsif ($limit_id eq 'age')
  {
    if ($limit =~ /^[0-9]+$/)
    {
      if ($limit >= 0)
      {
        if (open(LIMITFILE, '>' . $limit_file_age))
        {
          print LIMITFILE $limit . "\n";
          close(LIMITFILE);

          print 'perltrash: age limit changed to ';
          if ($limit > 0)
          {
            print $limit . " days\n";
          }
          else
          {
            print "unlimited\n";
          }

          return 1;
        }

        print_error('couldn\'t open ' . $limit_file_age . ': ' . $!);
      }
    }
    else
    {
      print_error('age limit: ' . $limit . ': invalid limit');
    }
  }
  else
  {
    print_error('limit: ' . $limit_id . ': invalid limit identifier');
  }

  return 0;
}

sub convert_size_limit
{
  my $limit = shift();
  my $multiplier = 1;

  if ($limit =~ /^[0-9]+K$/)
  {
    $multiplier = 1024;
    $limit =~ s/^([0-9]+)K$/\1/;
  }
  elsif ($limit =~ /^[0-9]+M$/)
  {
    $multiplier = 1024 * 1024;
    $limit =~ s/^([0-9]+)M$/\1/;
  }
  elsif ($limit =~ /^[0-9]+G/)
  {
    $multiplier = 1024 * 1024 * 1024;
    $limit =~ s/^([0-9]+)G$/\1/;
  }
  elsif ($limit !~ /^[0-9]+$/)
  {
    print_error('size limit: ' . $limit . ': invalid limit');
    return -1;
  }

  return $limit * $multiplier;
}


sub get_limit
{
  my $limit_id = shift();
  my $limit;

  if (open(LIMITFILE, catdir($ENV{'HOME'}, '.perltrash', 'limit-' . $limit_id)))
  {
    $limit = <LIMITFILE>;
    close(LIMITFILE);

    $limit =~ s/[\r\n]//g;
    if ($limit =~ /^[0-9]+$/)
    {
      return $limit;
    }
  }

  return 0;
}


sub print_usage
{
  # maximum line length: 75 (TABs count 8)
  print qq(Usage: perltrash [--] FILE ...
       perltrash -l
       perltrash -r ID ...
       perltrash -R ID ...
       perltrash -e
       perltrash -M IDENTIFIER LIMIT

FILE
\tFile/directory/... to delete. Multiple FILEs may appear on the
\tcommand line.

-l, --list
\tList contents of trash can.

-r, --restore
\tRestore file/directory/... specified by ID to its original
\tlocation. Multiple IDs may appear after the -r (or --restore)
\toption.

-R, --restore-here
\tRestore file/directory/... specified by ID into the current
\tworking directory. Multiple IDs may appear after the -R (or
\t--restore-here) option.

-e, --empty
\tEmpty the trash can.

-M, --limit
\tLimit the maximum size of the trash can. Note that the new limit
\twill be imposed on the trash can when deleting files only. Merely
\tsetting a new limit or listing the trash can\'s contents does not
\tchange the contents.

\tYou can impose different limits simultaneously:

\tsize
\t\tLimit the maximum size of the trash can (in bytes). The
\t\ttrash can will never grow past this limit. If you set this
\t\tlimit to 0, there will be no limit on the trash can size.

\t\tLIMIT may be suffixed with the following characters to
\t\tchange its meaning: 'K' (specify size in kilobytes rather
\t\tthan bytes), 'M' (in megabytes), or 'G' (in gigabytes).

\t\t(default: 0)

\tage
\t\tLimit the maximum deletion date of files in the trash can
\t\t(in days). Files in the trash can that have been deleted
\t\tbefore this number of days will be permanently removed.
\t\tIf you set this limit to 0, there will be no limit on
\t\tdeletion age.

\t\t(default: 0)

\tExamples:
\t\t# permanently remove old files if the trash can would grow
\t\t# past 2 gigabytes
\t\tperltrash -M size 2G

\t\t# permanently remove old files that have been deleted more
\t\t# than 30 days ago
\t\tperltrash -M age 30

--
\tStop parsing of options. Everything that follows "--" will be
\ttreated as a FILE.

-V, --version
\tPrint perltrash version number.

-?, -h, --help
\tPrint this help.
);
}


sub print_version
{
  print qq(perltrash $version
Copyright (C) 2002 Maik Schreiber
Distributed under the terms of the GNU General Public License v2 or later
);
}


sub main
{
  my $ACTION_TRASH = 1;
  my $ACTION_RESTORE = 2;
  my $ACTION_RESTORE_HERE = 3;
  my $ACTION_EMPTY = 4;

  my $arg;
  my @files;
  my $action = $ACTION_TRASH;
  my $limit_id;
  my $limit;
  my $rc;

  if (create_trashdir() == 0)
  {
    return 1;
  }

  # check out options
  while ($arg = shift(@ARGV))
  {
    if (($arg eq '-?') || ($arg eq '-h') || ($arg eq '--help'))
    {
      print_usage();
      return 0;
    }
    elsif (($arg eq '-V') || ($arg eq '--version'))
    {
      print_version();
      return 0;
    }
    elsif (($arg eq '-l') || ($arg eq '--list'))
    {
      list_trashcan();
      return 0;
    }
    elsif (($arg eq '-r') || ($arg eq '--restore'))
    {
      $action = $ACTION_RESTORE;
    }
    elsif (($arg eq '-R') || ($arg eq '--restore-here'))
    {
      $action = $ACTION_RESTORE_HERE;
    }
    elsif (($arg eq '-e') || ($arg eq '--empty'))
    {
      if (empty_trashcan() == 1)
      {
        return 0;
      }

      return 1;
    }
    elsif (($arg eq '-M') || ($arg eq '--limit'))
    {
      if (($#ARGV + 1) < 2)
      {
        print_error($arg . ': not enough parameters');
        return 1;
      }

      $limit_id = shift(@ARGV);
      $limit = shift(@ARGV);
      if (set_limit($limit_id, $limit) == 1)
      {
        return 0;
      }

      return 1;
    }
    elsif ($arg eq '--')
    {
      last;
    }
    elsif (substr($arg, 0, 1) eq '-')
    {
      print_error($arg . ": unknown option\n" .
                  '(use "perltrash --help" to get a list of valid options)');
      return 1;
    }
    else
    {
      unshift(@ARGV, $arg);
      last;
    }
  }

  # get file list
  foreach $arg (@ARGV)
  {
    push(@files, $arg);
  }

  if (($#files + 1) > 0)
  {
    if ($action == $ACTION_TRASH)
    {
      if (trash_files(@files) == 1)
      {
        return 0;
      }

      return 1;
    }
    elsif (($action == $ACTION_RESTORE) || ($action == $ACTION_RESTORE_HERE))
    {
      $rc = 0;

      if ($action == $ACTION_RESTORE)
      {
        $rc = restore_files(0, @files);
      }
      else
      {
        $rc = restore_files(1, @files);
      }

      if ($rc == 1)
      {
        return 0;
      }

      return 1;
    }
  }

  print_error("no files specified\n" .
              '(use "perltrash --help" to get a list of valid options)');
  return 1;
}


exit(main());

