12

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

为此，我必须测试第一个输入变量是否是文件句柄。我通过阅读这个问题想出了如何做到这一点。

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

这是我想要做的：

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;
  }
  ...
}

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

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

4

5 回答 5

15

检测把手的开放性

正如 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使用caller' 包——它当然经常如此。

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

这是您的问题的答案：

#!/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

现在快乐吗，施韦恩？☺

于 2010-11-17T00:32:45.317 回答
7

仍在尝试此操作，但也许您可以尝试对文件句柄进行零字节 syswrite 并检查错误：

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"
}
于 2010-09-27T20:03:45.497 回答
3

如果您正在使用IO（并且应该），那么$handle->opened会告诉您是否打开了句柄。可能需要更深入地了解它的模式。

于 2010-11-16T20:42:40.963 回答
2

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

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

如果您想将打开文件的责任委托给调用者，请将适当的异常处理委托给调用者。这允许调用者选择适当的响应。绝大多数情况下，要么死亡，要么警告或修复给你带来不好处理的有问题的代码。

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

首先，如果您可以查看 CPAN 上的TryCatch或Try::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
于 2010-09-30T02:33:50.267 回答
1

-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
于 2010-09-27T19:59:42.107 回答