Почему я не могу удалить этот пустой каталог в Perl? - PullRequest
Новая
       22

Почему я не могу удалить этот пустой каталог в Perl?

4 голосов
/ 08 декабря 2008

Я конвертирую скрипт Linux из http://www.perlmonks.org/index.pl?node_id=217166, а именно: 

#!/usr/bin/perl -w
use strict;
use Getopt::Std;
use File::Find;

@ARGV > 0 and getopts('a:', \my %opt) or die << "USAGE";
# Deletes any old files from the directory tree(s) given and
# removes empty directories en passant.
usage: $0 [-a maxage] directory [directory ...]
       -a  maximum age in days, default is 120
USAGE

my $max_age_days = $opt{a} || 120;

find({
    wanted => sub { unlink if -f $_ and -M _ > $max_age_days },
    postprocess => sub { rmdir $File::Find::dir },
}, @ARGV);

моя попытка: 

#!/usr/bin/perl -w
use strict;
use Getopt::Std;
use File::Find;


@ARGV > 0 and getopts('a:', \my %opt) or die << "USAGE";
# Deletes any old files from the directory tree(s) given and
# removes empty directories en passant.
usage: $0 [-a maxage] directory [directory ...]
       -a  maximum age in days, default is 120
USAGE

my $max_age_days = $opt{a} || 120;

find({
    wanted => sub { unlink if -f $_ and -M _ > $max_age_days },
#    postprocess => sub { rmdir $File::Find::dir },
    postprocess => sub {
                        my $expr = "$File::Find::dir";
                        $expr =~ s/\//\\/g;      # replace / with \
                        print "rmdir $expr\n";
                        `rmdir $expr`;
                        },
}, @ARGV);

Однако я получаю сообщение об ошибке, когда скрипт пытается удалить каталог, говоря, что каталог используется другим процессом (если это не так). Есть идеи? Я запускаю сценарий на 64-разрядной версии Windows Server 2003 с пакетом обновления 2 (SP2), используя ActiveState 5.10.

Спасибо!

Ответы [ 4 ]

16 голосов
/ 08 декабря 2008

Из этой документации

постобработки

Значение должно быть ссылкой на код. вызывается как раз перед оставив в настоящее время обработано каталог . Это называется недействительным контекст без аргументов. Имя текущий каталог находится в $ File :: Find :: реж. Этот крючок удобен для суммирования каталога, такого как вычисление использования его диска. когда follow или follow_fast действуют, постпроцесс не работает.

Это означает, что ваш собственный код все еще использует каталог, когда вы пытаетесь удалить его. Попробуйте создать список имен и повторить его после вызова, чтобы найти.

Другое возможное решение - использовать опцию no_chdir, чтобы избежать использования директорий, которые вы хотите удалить.

РЕДАКТИРОВАТЬ: Этот комментарий также имеет отношение, поэтому я продвигаю его в основной текст ответа:

К этому следует добавить: проблема в том, что в Linux можно удалять используемые файлы и каталоги, а в Windows - нет. Вот почему это не работает без изменений. - Леон Тиммерманс

9 голосов
/ 08 декабря 2008

Всего несколько заметок:

  1. Вам не нужно переворачивать / на \. Perl понимает, что / является разделителем каталогов, даже в Windows.
  2. rmdir - встроенный Perl, вам не нужно вызывать его с помощью обратных кавычек.
4 голосов
/ 08 декабря 2008

Версия perlmonks использует метод Perl "rmdir" для удаления. Ваша версия порождает подоболочку с обратными кавычками. Поэтому вполне возможно, что сообщение правильное - каталог все еще используется Perl, когда rmdir пытается его использовать.

1 голос
/ 11 декабря 2008

Спасибо за все ваши ответы. Мой последний сценарий выглядит так: 

#!/usr/bin/perl -w
use strict;
use warnings;
use Getopt::Std;
use File::Find;
use Win32::OLE;

@ARGV > 0 and getopts('a:', \my %opt) or die << "USAGE";
Deletes any old files from the directory tree(s) given and
removes empty directories en passant.
usage: $0 [-a maxage] directory [directory ...]
       -a  maximum age in days, default is 30
USAGE

my $max_age_days = $opt{a} || 30;
my @dir_list = undef;

find({
    wanted => sub { if (-f $_ and -M _ > $max_age_days) {
        unlink $_ or LogError ("$0: Could not delete $_ ($!)")}},
    postprocess => sub {push(@dir_list,$File::Find::dir)},
}, @ARGV);

if (@dir_list) {foreach my $thisdir (@dir_list) { rmdir $thisdir if defined ($thisdir)}}

############
sub LogError {
    my ($strDescr) = @_;
    use constant EVENT_SUCCESS => 0;
    use constant EVENT_ERROR => 1;
    use constant EVENT_WARNING => 3;
    use constant EVENT_INFO => 4;

    my $objWSHShell = Win32::OLE->new('WScript.Shell');
    $objWSHShell->LogEvent(EVENT_ERROR, $strDescr);
}

Кажется, отлично работает - вы можете придумать, как его улучшить?

...