File Coverage

blib/lib/Bot/Cobalt/Logger/Output/File.pm

Criterion	Covered	Total	%
statement	72	81	88.8
branch	24	42	57.1
condition	7	12	58.3
subroutine	15	15	100.0
pod	3	4	75.0
total	121	154	78.5

package Bot::Cobalt::Logger::Output::File;
$Bot::Cobalt::Logger::Output::File::VERSION = '0.021001';
use v5.10;
use strictures 2;
use Carp;

use Time::HiRes 'sleep';
use IO::File ();
use Fcntl qw/:DEFAULT :flock/;

# ... after which we fall back to warning on stderr with message included:
sub FLOCK_TIMEOUT () { 0.5 }


sub PATH   () { 0 }
sub HANDLE () { 1 }
sub MODE   () { 2 }
sub PERMS  () { 3 }
sub INODE  () { 4 }
sub RUNNING_IN_HELL () { 5 }

sub new {
  my $class = shift;

  my $self = [
    '',     ## PATH
    undef,  ## HANDLE
    undef,  ## MODE
    undef,  ## PERMS
    undef,  ## INODE
    0,      ## RUNNING_IN_HELL
  ];

  bless $self, $class;

  my %args = @_;
  $args{lc $_} = delete $args{$_} for keys %args;

  confess "new() requires a 'file' argument"
    unless defined $args{file};

  $self->file( $args{file} );

  $self->mode( $args{mode} )
    if defined $args{mode};

  $self->perms( $args{perms} )
    if defined $args{perms};

  if ($^O eq 'MSWin32' or $^O eq 'VMS') {
    $self->[RUNNING_IN_HELL] = 1
  }

  ## Try to open/create file when object is constructed
  $self->_open or croak "Could not open specified file ".$args{file};
  $self->_close if $self->[RUNNING_IN_HELL];

  $self
}

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

  if (defined $file) {
    $self->_close if $self->_is_open;

    # stringify a Path::Tiny ->
    $self->[PATH] = $file . '';

    $self->_open unless $self->[RUNNING_IN_HELL];
  }

  $self->[PATH]
}

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

  return $self->[MODE] = $mode if defined $mode;

  $self->[MODE] //= O_WRONLY | O_APPEND | O_CREAT
}

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

  return $self->[PERMS] = $perms if defined $perms;

  $self->[PERMS] //= 0666
}

sub _open {
  my ($self) = @_;

  my $fh;
  unless (sysopen($fh, $self->file, $self->mode, $self->perms) ) {
    warn(
      "Log file could not be opened: ",
      join ' ', $self->file, $!
    );
    return
  }

  binmode $fh, ':utf8';
  $fh->autoflush;

  $self->[INODE] = ( stat $self->file )[1]
    unless $self->[RUNNING_IN_HELL];

  $self->[HANDLE] = $fh
}

sub _close {
  my ($self) = @_;

  return 1 unless $self->_is_open;

  close $self->[HANDLE];
  $self->[HANDLE] = undef;

  1
}

sub _is_open {
  my ($self) = @_;
  $self->[HANDLE]
}

sub _do_reopen {
  my ($self) = @_;

  ## Are we on a stupid system or dealing with a not-open file?
  return 1 unless $self->_is_open;

  unless ( $self->[RUNNING_IN_HELL] ) {
    ## Do the inodes match?
    return if -e $self->file
      and $self->[INODE] == ( stat $self->file )[1];
  }

  1
}

sub _write {
  my ($self, $str) = @_;

  if ($self->_do_reopen) {
    $self->_close;
    $self->_open or warn "_open failure" and return;
  }

  ## FIXME if flock fails, buffer and try next _write up to X items ?
  my $timer = 0;
  until ( flock($self->[HANDLE], LOCK_EX | LOCK_NB) ) {
    if ($timer > FLOCK_TIMEOUT) {
      warn "flock failure for '@{[$self->file]}' ('$str')";
      return
    }
    sleep 0.01;
    $timer += 0.01;
  }

  print { $self->[HANDLE] } $str;

  flock($self->[HANDLE], LOCK_UN);

  $self->_close if $self->[RUNNING_IN_HELL];

  1
}


1;
__END__