Perl: Redirect STDERR to a file without creating an empty file?

I'm redirecting STDOUT and STDERR in a perl script with:

open STDOUT, '>', $logfile or die "Can't redirect STDOUT: $!";
open STDERR, ">&STDOUT" or die "Can't dup for STDERR: $!";

saving and restoring the file handles开发者_运维问答 before and after ...

Thing is, if there's no output from the program I end up with a size 0 file but I'd like to have no file at all. How can I do that without resorting to checking and deleting the file manually?

Thanks!

You could tie STDOUT to a class that delays opening of the destination file until the first time the handle is written to:

package FastidiousHandle;

use Tie::StdHandle;
use strict;

our @ISA = 'Tie::StdHandle';

sub TIEHANDLE {
    my ($class, @args) = @_;
    my $self = $class->SUPER::TIEHANDLE;
    ${*$self}{openargs} = \@args;
    return $self;
}

sub WRITE {
    my $self = shift;
    my $openargs = delete ${*$self}{openargs};
    $self->OPEN(@$openargs) if $openargs;
    $self->SUPER::WRITE(@_);
}

1;

Then in your main program, you'd say:

tie *STDOUT, 'FastidiousHandle', '>', $path;
my $saved_stderr = *STDERR;
*STDERR = *STDOUT;

To restore the previous handles you'd say:

*STDERR = $saved_stderr;
untie *STDOUT;

Just check at the end if anything has been written, and if not, remove the file. Make sure you have autoflush on.

use IO::Handle;
...
open STDOUT, '>', $logfile or die "Can't redirect STDOUT: $!";
open STDERR, ">&STDOUT" or die "Can't dup for STDERR: $!";

STDOUT->autoflush(1);
STDERR->autoflush(1);

...

END {
    unlink $logfile if -z $logfile;
}

Or in the old style...

open STDOUT, '>', $logfile or die "Can't redirect STDOUT: $!";
open STDERR, ">&STDOUT" or die "Can't dup for STDERR: $!";
select(STDERR); $|=1; select(STDOUT); $|=1;

END {
    unlink $logfile if -z $logfile;
}

The only way I can think of is to fork off a subprocess which sends back everything via pipe (think IO::Pipe or something like IPC::Open2 - either way, you still redirect your STDERR to STDOUT in the child), and then in the parent, write the stuff you get in the pipe to the log file - this allows you to open the logfile when you first have data. For example:

#!/usr/bin/perl

use Proc::Fork;
use IO::Pipe;

sub pipe_to_logfile
{
    my $log = shift;
    my @cmd = @_;

    my $pipe = IO::Pipe->new();

    run_fork {
        child {
            $pipe->writer();
            open STDOUT, '>&', $pipe or die "Can't redirect STDOUT: $!";
            open STDERR, '>&STDOUT'  or die "Can't redirect STDERR: $!";

            exec(@cmd);
        }
        parent {
            $pipe->reader();
            my $fh;

            while(<$pipe>)
            {
                unless ($fh)
                {
                    open $fh, '>', $log or die "Can't write to $log: $!";
                }
                print $fh $_;
            }
        }
    }
}

pipe_to_logfile('/tmp/true.out', 'true');
pipe_to_logfile('/tmp/ls.out', qw(ls /));

When I run this, I get:

$ ls /tmp/*.out
ls: cannot access /tmp/*.out: No such file or directory
$ cd tmp
$ perl foo.pl
$ ls /tmp/*.out
/tmp/ls.out

Hope that helps.

You don't want to delay opening the file, if you do delay the open any problems like a permission error, or a missing directory in the path to the file will cause the program to fail at the first print statement. Given that it sounds like you might have program runs that never print anything you could likely face your program failing at some random time in the future because it just happened to print to a file that it couldn't open for months. By then you, or your successor might have forgotten this feature ever existed.

It's much better to check the file after your done to see if it's empty and remove it if it is. You can wrap the logic in a class if you want to do it for you.

package My::File;
use strict;
use warnings;
use base qw(IO::File);

sub new {
    my ($class, $file, @args) = @_;
    my $self = $class->SUPER::new($file, @args);
    if ($self) {
        *{$self}->{file} = $file;
    }
    return $self;
}

sub DESTROY {
    local $@;
    my ($self) = @_;
    $self->flush;
    if (-e *{$self}->{file} && -z *{$self}->{file}) {
        unlink *{$self}->{file};
    }
    return;
}

package main;

my $fh1 = My::File->new("file_1", "w");
my $fh2 = My::File->new("file_2", "w");

print $fh1 "This file should stay\n";

This code isn't really production ready, it doesn't try to handle all the ways IO::File->new() can be called, and it should also override calls to $file_obj->open() in a similar manner to new. It also could do with better error handling.