File Coverage

blib/lib/File/Stamped.pm

Criterion	Covered	Total	%
statement	87	99	87.8
branch	27	48	56.2
condition	12	24	50.0
subroutine	21	21	100.0
pod	3	3	100.0
total	150	195	76.9

package File::Stamped;
use strict;
use warnings;
use 5.008001;
our $VERSION = '0.09';
use Carp ();
use POSIX ();
use SelectSaver ();
use File::Path ();
use File::Basename ();

sub new {
    my $class = shift;
    my %args = @_==1?%{$_[0]}:@_;
    if (exists($args{pattern}) && exists($args{callback})) {
        Carp::croak "Both 'pattern' and 'callback' cannot be specified.";
    }
    unless (exists($args{pattern}) || exists($args{callback})) {
        Carp::croak "You need to specify 'pattern' or 'callback'.";
    }
    if (defined $args{symlink} && ! -l $args{symlink} && -e _) {
        Carp::croak "File '$args{symlink}' already exists (not a symlink)";
    }
    my $callback = delete($args{callback}) || _make_callback_from_pattern(delete($args{pattern}));
    my $self = bless \do { local *FH }, $class;
    tie *$self, $class, $self;
    %args = (
        autoflush         => 1,
        close_after_write => 1,
        iomode            => '>>:utf8',
        rotationtime      => 1,
        callback          => $callback,
        auto_make_dir     => 0,
        %args,
    );
    for my $k (keys %args) {
        *$self->{$k} = $args{$k};
    }
    return $self;
}

sub TIEHANDLE {
    (
        ( defined( $_[1] ) && UNIVERSAL::isa( $_[1], __PACKAGE__ ) )
        ? $_[1]
        : shift->new(@_)
    );
}

sub PRINT     { shift->print(@_) }

sub WRITE     { shift->syswrite(@_) }

sub _gen_filename {
    my $self = shift;
    return *$self->{callback}->(*$self);
}

sub _make_callback_from_pattern {
    my ($pattern) = shift;

    return sub {
        my $self = shift;
        my $time = time();
        if ( $time > 1 ) {
            $time = $time - $time % $self->{rotationtime};
        }
        return POSIX::strftime($pattern, localtime($time));
    };
}

sub _gen_symlink {
    my ($self, $fname) = @_;

    if (defined(my $symlink = *$self->{symlink})) {
        if (-l $symlink) {
            my $link = readlink $symlink;
            if (defined $link && $link ne $fname) {
                unlink $symlink;
            }
        }
        symlink $fname, $symlink;
    }
}

sub _output {
    my ($self, $callback) = @_;

    my $fname = $self->_gen_filename();
    if (*$self->{auto_make_dir}) {
        File::Path::make_path(File::Basename::dirname($fname));
    }
    my $fh;
    if (*$self->{fh}) {
        if ($fname eq *$self->{fname} && *$self->{pid}==$$) {
            $fh = delete *$self->{fh};
        } else {
            my $fh = delete *$self->{fh};
            close $fh if $fh;
        }
    }

    $fh = $callback->($fh, $fname);

    if (*$self->{close_after_write}) {
        close $fh;
    } else {
        *$self->{fh}    = $fh;
        *$self->{fname} = $fname;
        *$self->{pid}   = $$;
    }
}

sub print {
    my $self = shift;

    my @msg = @_;

    $self->_output(sub {
        my ($fh, $fname) = @_;
        unless ($fh) {
            open $fh, *$self->{iomode}, $fname or die "Cannot open file($fname): $!";
            if (*$self->{autoflush}) {
                my $saver = SelectSaver->new($fh);
                $|=1;
            }
            $self->_gen_symlink($fname);
        }
        print {$fh} @msg
            or die "Cannot write to $fname: $!";

        $fh;
    });
}

sub syswrite {
    my $self = shift;

    my ($buf, @args) = @_;

    local *$self->{iomode} = '>>:raw'; # perl-5.30 syswrite compatibility

    $self->_output(sub {
        my ($fh, $fname) = @_;
        unless ($fh) {
            open $fh, *$self->{iomode}, $fname or die "Cannot open file($fname): $!";
            $self->_gen_symlink($fname);
        }
        my $res = @args == 0 ? CORE::syswrite($fh, $buf)
                : @args == 1 ? CORE::syswrite($fh, $buf, $args[0])
                : @args == 2 ? CORE::syswrite($fh, $buf, $args[0], $args[1])
                : Carp::croak 'Too many arguments for syswrite';
        die "Cannot write to $fname: $!" unless $res;

        $fh;
    });
}

1;
__END__