如何测试是否可以写入文件句柄？

Question

我有一些子例程，我这样调用 myWrite($fileName, \@data)。 myWrite() 打开文件并以某种方式写出数据。我想修改myWrite，以便我可以像上面或那样调用它，并将文件句柄作为第一个参数。 （此修改的主要原因是将文件的打开委托给调用脚本而不是模块。如果有更好的解决方案来告诉 IO 子例程在哪里写入，我很高兴听到它。 ）

为了做到这一点，我必须测试第一个输入 var 是否是文件句柄。我通过阅读 这个问题。

现在这是我的问题：我还想测试是否可以写入这个文件句柄。我不知道该怎么做。

这就是我想要做的：

sub myWrite {
  my ($writeTo, $data) = @_;
  my $fh;
  if (isFilehandle($writeTo)) { # i can do this
    die "you're an immoral person\n" 
      unless (canWriteTo($writeTo)); # but how do I do this?
    $fh = $writeTo;
  } else {
    open $fh, ">", $writeTo;
  }
  ...
}

我需要知道的是我是否可以写入文件句柄，尽管很高兴看到一些通用解决方案告诉您文件句柄是否是用“>>”打开的或“<”，或者未打开等。

（请注意 这个问题相关，但似乎没有回答我的问题。）

Answer 1

检测句柄的打开情况

正如 Axeman 指出的那样，$handle->opened() 会告诉您它是否打开。

use strict;
use autodie;
use warnings qw< FATAL all >;
use IO::Handle;
use Scalar::Util qw< openhandle >;

our $NULL = "/dev/null";
open NULL;
printf "NULL is %sopened.\n", NULL->opened() ? "" : "not ";
printf "NULL is %sopenhandled.\n", openhandle("NULL") ? "" : "not ";
printf "NULL is fd %d.\n", fileno(NULL);

如您所见

NULL is opened.
NULL is not openhandled.
NULL is fd 3.

，您不能使用 Scalar::Util::openhandle() ，因为它太愚蠢且有缺陷。

打开句柄压力测试

如果您没有使用 IO::Handle->opened，正确的方法在以下简单的三语言小脚本中进行了演示：

eval 'exec perl $0 ${1+"$@"}'
               if 0;

use 5.010_000;
use strict;
use autodie;
use warnings qw[ FATAL all ];

use Symbol;
use IO::Handle;

#define exec(arg)
BEGIN { exec("cpp $0 | $^X") } #!/usr/bin/perl -P
#undef  exec

#define SAY(FN, ARG) printf("%6s %s => %s\n", short("FN"), q(ARG), FN(ARG))
#define STRING(ARG)  SAY(qual_string, ARG)
#define GLOB(ARG)    SAY(qual_glob, ARG)
#define NL           say ""
#define TOUGH        "hard!to!type"

sub comma(@);
sub short($);
sub qual($);
sub qual_glob(*);
sub qual_string($);

$| = 1;

main();
exit();

sub main { 

    our $GLOBAL = "/dev/null";
    open GLOBAL;

    my $new_fh = new IO::Handle;

    open(my $null, $GLOBAL);

    for my $str ($GLOBAL, TOUGH) {
        no strict "refs";
        *$str = *GLOBAL{IO};
    }

    STRING(  *stderr       );
    STRING(  "STDOUT"      );
    STRING(  *STDOUT       );
    STRING(  *STDOUT{IO}   );
    STRING( \*STDOUT       );
    STRING( "sneezy"       );
    STRING( TOUGH );
    STRING( $new_fh        );
    STRING( "GLOBAL"       );
    STRING( *GLOBAL        );
    STRING( $GLOBAL        );
    STRING( $null          );

    NL;

    GLOB(  *stderr       );
    GLOB(   STDOUT       );
    GLOB(  "STDOUT"      );
    GLOB(  *STDOUT       );
    GLOB(  *STDOUT{IO}   );
    GLOB( \*STDOUT       );
    GLOB(  sneezy        );
    GLOB( "sneezy"       );
    GLOB( TOUGH );
    GLOB( $new_fh        );
    GLOB(  GLOBAL        );
    GLOB( $GLOBAL        );
    GLOB( *GLOBAL        );
    GLOB( $null          );

    NL;

}

sub comma(@) { join(", " => @_) }

sub qual_string($) { 
    my $string = shift();
    return qual($string);
} 

sub qual_glob(*) { 
    my $handle = shift();
    return qual($handle);
} 

sub qual($) {
    my $thingie = shift();

    my $qname = qualify($thingie);
    my $qref  = qualify_to_ref($thingie); 
    my $fnum  = do { no autodie; fileno($qref) };
    $fnum = "undef" unless defined $fnum;

    return comma($qname, $qref, "fileno $fnum");
} 

sub short($) {
    my $name = shift();
    $name =~ s/.*_//;
    return $name;
} 

运行时会产生以下结果 ： ：

string    *stderr        => *main::stderr, GLOB(0x8368f7b0), fileno 2
string    "STDOUT"       => main::STDOUT, GLOB(0x8868ffd0), fileno 1
string    *STDOUT        => *main::STDOUT, GLOB(0x84ef4750), fileno 1
string    *STDOUT{IO}    => IO::Handle=IO(0x8868ffe0), GLOB(0x84ef4750), fileno 1
string   \*STDOUT        => GLOB(0x8868ffd0), GLOB(0x8868ffd0), fileno 1
string   "sneezy"        => main::sneezy, GLOB(0x84169f10), fileno undef
string   "hard!to!type"  => main::hard!to!type, GLOB(0x8868f1d0), fileno 3
string   $new_fh         => IO::Handle=GLOB(0x8868f0b0), IO::Handle=GLOB(0x8868f0b0), fileno undef
string   "GLOBAL"        => main::GLOBAL, GLOB(0x899a4840), fileno 3
string   *GLOBAL         => *main::GLOBAL, GLOB(0x84ef4630), fileno 3
string   $GLOBAL         => main::/dev/null, GLOB(0x7f20ec00), fileno 3
string   $null           => GLOB(0x86f69bb0), GLOB(0x86f69bb0), fileno 4

  glob    *stderr        => GLOB(0x84ef4050), GLOB(0x84ef4050), fileno 2
  glob     STDOUT        => main::STDOUT, GLOB(0x8868ffd0), fileno 1
  glob    "STDOUT"       => main::STDOUT, GLOB(0x8868ffd0), fileno 1
  glob    *STDOUT        => GLOB(0x8868ffd0), GLOB(0x8868ffd0), fileno 1
  glob    *STDOUT{IO}    => IO::Handle=IO(0x8868ffe0), GLOB(0x84ef4630), fileno 1
  glob   \*STDOUT        => GLOB(0x8868ffd0), GLOB(0x8868ffd0), fileno 1
  glob    sneezy         => main::sneezy, GLOB(0x84169f10), fileno undef
  glob   "sneezy"        => main::sneezy, GLOB(0x84169f10), fileno undef
  glob   "hard!to!type"  => main::hard!to!type, GLOB(0x8868f1d0), fileno 3
  glob   $new_fh         => IO::Handle=GLOB(0x8868f0b0), IO::Handle=GLOB(0x8868f0b0), fileno undef
  glob    GLOBAL         => main::GLOBAL, GLOB(0x899a4840), fileno 3
  glob   $GLOBAL         => main::/dev/null, GLOB(0x7f20ec00), fileno 3
  glob   *GLOBAL         => GLOB(0x899a4840), GLOB(0x899a4840), fileno 3
  glob   $null           => GLOB(0x86f69bb0), GLOB(0x86f69bb0), fileno 4

这就是测试打开文件句柄的方法！

但我相信这甚至不是你的问题。

尽管如此，我还是觉得这个问题需要解决，因为这个问题有太多不正确的解决方案。人们需要睁开眼睛看看这些东西实际上是如何运作的。请注意，如果需要，Symbol 中的两个函数会使用调用者 的包——这当然经常发生。

确定开放句柄的读/写模式

这是您问题的答案：

#!/usr/bin/env perl

use 5.10.0;
use strict;
use autodie;
use warnings qw< FATAL all >;

use Fcntl;

my (%flags, @fh);
my $DEVICE  = "/dev/null";
my @F_MODES = map { $_ => "+$_" } qw[ < > >> ];
my @O_MODES = map { $_ | O_WRONLY }
        O_SYNC                          ,
                 O_NONBLOCK             ,
        O_SYNC              | O_APPEND  ,
                 O_NONBLOCK | O_APPEND  ,
        O_SYNC | O_NONBLOCK | O_APPEND  ,
    ;

   open($fh[++$#fh], $_, $DEVICE) for @F_MODES;
sysopen($fh[++$#fh], $DEVICE, $_) for @O_MODES;

eval { $flags{$_} = main->$_ } for grep /^O_/, keys %::;

for my $fh (@fh) {
    printf("fd %2d: " => fileno($fh));
    my ($flags => @flags) = 0+fcntl($fh, F_GETFL, my $junk);
    while (my($_, $flag) = each %flags) {
        next if $flag == O_ACCMODE;
        push @flags => /O_(.*)/ if $flags & $flag;
    }
    push @flags => "RDONLY" unless $flags & O_ACCMODE;
    printf("%s\n",  join(", " => map{lc}@flags));
}

close $_ for reverse STDOUT => @fh;

运行时，会产生以下输出：

fd  3: rdonly
fd  4: rdwr
fd  5: wronly
fd  6: rdwr
fd  7: wronly, append
fd  8: rdwr, append
fd  9: wronly, sync
fd 10: ndelay, wronly, nonblock
fd 11: wronly, sync, append
fd 12: ndelay, wronly, nonblock, append
fd 13: ndelay, wronly, nonblock, sync, append

现在快乐，Schwern？ ☺

Answer 2

仍在尝试这一点，但也许您可以尝试将零字节系统写入文件句柄并检查错误：

open A, '<', '/some/file';
open B, '>', '/some/other-file';

{
    local $! = 0;
    my $n = syswrite A, "";
    # result: $n is undef, $! is "Bad file descriptor"
}
{
    local $! = 0;
    my $n = syswrite B, "";
    # result: $n is 0, $! is ""
}

fcntl 看起来也很有希望。你的里程可能会有所不同，但类似这样的事情可能是在正确的轨道上：

use Fcntl;
$flags = fcntl HANDLE, F_GETFL, 0;  # "GET FLags"
if (  ($flags & O_ACCMODE) & (O_WRONLY|O_RDWR) ) {
    print "HANDLE is writeable ...\n"
}

Answer 3

如果您使用 IO （您应该这样做），那么 < code>$handle->opened 会告诉您句柄是否打开。可能需要更深入地研究才能说出其模式。

Answer 4

听起来您正在尝试重新发明异常处理。不要那样做。除了只写句柄之外，还有很多潜在的错误。被交给一个封闭的手柄怎么样？存在错误的句柄？

mobrule 的方法使用 use Fcntl; 正确确定文件句柄上的标志，但这通常不处理错误和警告。

如果要将打开文件的责任委托给调用者，请将适当的异常处理委托给调用者。这允许调用者选择适当的响应。绝大多数时候，要么是死掉，要么是警告或修复那些给你带来不好处理的违规代码。

有两种方法可以处理传递给您的文件句柄上的异常。

首先，如果您可以查看 TryCatch 或 在 CPAN 上尝试::Tiny 并使用该方法异常处理。我使用 TryCatch，它非常棒。

第二种方法是使用 eval 并在 eval 完成后捕获适当的错误或警告。

如果您尝试写入只读文件句柄，则会生成警告。捕获尝试写入时生成的警告，然后可以向调用者返回成功或失败。

这是一个示例：

use strict; use warnings;

sub perr {
    my $fh=shift;
    my $text=shift;
    my ($package, $file, $line, $sub)=caller(0);
    my $oldwarn=$SIG{__WARN__};
    my $perr_error;

    {
        local $SIG{__WARN__} = sub { 
            my $dad=(caller(1))[3];
            if ($dad eq "(eval)" ) {
                $perr_error=$_[0];
                return ;
            }   
            oldwarn->(@_);
        };
        eval { print $fh $text }; 
    }    

    if(defined $perr_error) {
        my $s="$sub, line: $line";
        $perr_error=~s/line \d+\./$s/ ;
        warn "$sub called in void context with warning:\n" .  
             $perr_error 
             if(!defined wantarray);
        return wantarray ? (0,$perr_error) : 0;
    }
    return wantarray ? (1,"") : 1;
}

my $fh;
my @result;
my $res;
my $fname="blah blah file";

open $fh, '>', $fname;

print "\n\n","Successful write\n\n" 
     if perr $fh, "opened by Perl and writen to...\n";

close $fh;

open $fh, '<', $fname;

# void context:
perr $fh, "try writing to a read-only handle";

# scalar context:
$res=perr $fh, "try writing to a read-only handle";


@result=perr $fh, "try writing to a read-only handle";
if  ($result[0]) {
   print "SUCCESS!!\n\n";
} else {
    print "\n","I dunno -- should I die or warn this:\n";
    print $result[1];
}   

close $fh;
@result=perr $fh, "try writing to a closed handle";
if  ($result[0]) {
   print "SUCCESS!!\n\n";
} else {
    print "\n","I dunno -- should I die or warn this:\n";
    print $result[1];
}

输出：

Successful write

main::perr called in void context with warning:
Filehandle $fh opened only for input at ./perr.pl main::perr, line: 49

I dunno -- should I die or warn this:
Filehandle $fh opened only for input at ./perr.pl main::perr, line: 55

I dunno -- should I die or warn this:
print() on closed filehandle $fh at ./perr.pl main::perr, line: 64

Answer 5

-w 运算符可用于测试文件或文件句柄是否可写

open my $fhr, '<', '/etc/passwd' or die "$!";
printf("%s read from fhr\n", -r $fhr ? 'Can' : "Can't");
printf("%s write to fhr\n",  -w $fhr ? 'Can' : "Can't");

open my $fhw, '>', '/tmp/test' or die "$!";
printf("%s read from fhw\n", -r $fhw ? 'Can' : "Can't");
printf("%s write to fhw\n",  -w $fhw ? 'Can' : "Can't");

输出：

Can read from fhr
Can't write to fhr
Can read from fhw
Can write to fhw