How can I test if I can write to a filehandle?

Question

I have some subroutines that I call like this myWrite($fileName, \@data). myWrite() opens the file and writes out the data in some way. I want to modify myWrite so that I can call it as above or with a filehandle as the first argument. (The main reason for this modification is to delegate the opening of the file to the calling script rather than the module. If there is a better solution for how to tell an IO subroutine where to write, i'd be glad to hear it.)

In order to do this, I must test whether the first input var is a filehandle. I figured out how to do that by reading this question.

Now here's my question: I also want to test whether I can write to this filehandle. I can't figure out how to do that.

Here's what I want to do:

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

All I need to know is if I can write to the filehandle, though it would be nice to see some general solution that tells you whether you're filehandle was opened with ">>" or "<", or if it isn't open, etc.

(Note that this question is related but doesn't seem to answer my question.)

Answer 1

Detecting Openness of Handles

As Axeman points out, $handle->opened() tells you whether it is open.

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);

produces

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

As you see, you cannot use Scalar::Util::openhandle(), because it is just too stupid and buggy.

Open Handle Stress Test

The correct approach, if you were not using IO::Handle->opened, is demonstrated in the following simple little trilingual script:

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

Which when run produces:

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

That is how you test for open file handles!

But that wasn’t even your question, I believe.

Still, I felt it needed addressing, as there are too many incorrect solutions to that problem floating around here. People need to open their eyes to how these things actually work. Note that the two functions from Symbol use the caller’s package if necessary—which it certainly often is.

Determining Read/Write Mode of Open Handle

This is the answer to your question:

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

Which, when run, produces this output:

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

Happy now, Schwern? ☺

Answer 2

Still experimenting with this, but maybe you can try a zero-byte syswrite to a filehandle and check for errors:

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 looks promising too. Your mileage may vary, but something like this could be on the right track:

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

If you're using IO (and you should), then $handle->opened will tell you whether a handle is opened. Might have to delve deeper to tell its mode.

Answer 4

It sounds like you are trying to reinvent exception handling. Don't do that. There are lots of potential errors besides being handed a write-only handle. How about being handed a closed handle? A handle with an existing error?

mobrule's method with use Fcntl; correctly determines the flags on a filehandle, but this does not generally handle errors and warnings.

If you want to delegate to the caller the responsibility of opening the file, delegate to the caller the appropriate handling of exceptions. This allows the caller to choose the appropriate response. The vast majority of times, it will be either to die or warn or fix the offending code that handed you a bad handle.

There are two way to handle exceptions on a file handle passed to you.

First, if you can look at TryCatch or Try::Tiny on CPAN and use that method of exception handling. I use TryCatch and it is great.

A second method is use eval and catch the appropriate error or warning after the eval is finished.

If you attempt to write to a read-only file handle, it is a warning that is generated. Catch the warning that is generated from your attempted write and you can then return success or failure to the caller.

Here is an example:

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

The output:

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

The -w operator can be used to test whether a file or a filehandle is writeable

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");

Output:

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