Log::Info - Single interface for log output

  use Log::Info qw( :DEFAULT :log_levels :default_channels );

  Log  (CHAN_INFO, LOG_ERR,  "A fatal error occurred");
  Logf (CHAN_INFO, LOG_INFO, "Loading file: %s", $filename);

  Log::Info::add_sink               (CHAN_STATS, 'stats-file', 'FILE',
                                     LOG_INFO,
                                     { fn => "$ENV{HOME}/stats",
                                       maxsize => 10 * 1024**2, # 1M,
                                     });

  Log::Info::add_sink               (CHAN_DEBUG, 'stderr', 'FH', LOG_INFO,
                                     { fh => *STDERR{IO} })
    if $opt_debug;

  Log::Info::set_sink_out_level     (CHAN_INFO, SINK_STDERR, LOG_INFO);

  Log::Info::add_channel            ('MYLOG', $fh);
  Log::Info::set_channel_out_level  ('MYLOG', LOG_WARNING);
  Log::Info::add_sink               ('MYLOG', 'mysink', 'FILE', LOG_ERR,
                                     { fn => '/tmp/mylog' });
  Log                               ('MYLOG', LOG_INFO, 'I got to here...');
  Log::Info::delete_sink            ('MYLOG', 'outf');
  Log::Info::delete_channel         ('MYLOG');

  m!\[([\d_,.]+/[\d_,.]+|[\d_,.]+%)(\s+[^]]*)?\s+Done\]!

# (X)Emacs mode: -*- cperl -*-

#Implement log-input

#XXX Remove dependency to hairy Sys::Syslog

package Log::Info;

# ----------------------------------------------------------------------------

# Pragmas -----------------------------

require 5.005_62;
use strict;
use warnings;

# Inheritance -------------------------

use base qw( Exporter );
our (@EXPORT, @EXPORT_OK, %EXPORT_TAGS);

BEGIN {
  @EXPORT_OK = qw( $PACKAGE $VERSION );
}

# Utility -----------------------------

use Carp                        qw( carp croak );
use Env                         qw( @PATH );
use Fatal                  1.02 qw( :void close open seek sysopen );
use Fcntl                  1.03 qw( O_WRONLY O_APPEND O_CREAT O_EXCL );
use File::Spec::Functions   1.1 qw( catfile );
use FindBin                1.42 qw( $Script );
use IO::Handle             1.21 qw( );
use IO::Pipe              1.121 qw( );
use IO::Select             1.14 qw( );
use POSIX                  1.03 qw( strftime );
use Sys::Syslog            0.01 qw( openlog closelog syslog setlogmask setlogsock );

# fails under 5.6.
# require 'syslog.ph';

# ----------------------------------------------------------------------------

# -------------------------------------
# PACKAGE VARS
# -------------------------------------

my %channel;
our $dying;    # Set to one when calling within a caught 'die'
our $carping;  # Set to one when calling within a caught Carpism

# -------------------------------------
# PACKAGE CONSTANTS
# -------------------------------------

use constant ETA_ACCURACY => 5; # Update progress bar at least this often (in
                               # seconds) to ensure ETA is up-to-date

# All valid syslog levels (this is required by SYSLOG type documentation).
use constant LOG_LEVELS       => qw( LOG_EMERG   LOG_ALERT  LOG_CRIT LOG_ERR
                                     LOG_WARNING LOG_NOTICE LOG_INFO
                                     LOG_DEBUG );

use constant LOG_FACILITIES   => qw( FTY_AUTHPRIV FTY_CRON
                                     FTY_DAEMON FTY_LPR FTY_MAIL FTY_NEWS
                                     FTY_SYSLOG FTY_USER FTY_UUCP
                                     FTY_LOCAL0 FTY_LOCAL1 FTY_LOCAL2
                                     FTY_LOCAL3 FTY_LOCAL4 FTY_LOCAL5
                                     FTY_LOCAL6 FTY_LOCAL7
                                   );

use constant LOG_LEVEL        => { map { $_ => Sys::Syslog::xlate($_) }
                                       LOG_LEVELS
                                 };
use constant LOG_NAME         => { reverse %{LOG_LEVEL()} };

# In ascending numeric order
use constant LOG_LEVEL_VALUES => sort { $a <=> $b } values %{LOG_LEVEL()};

BEGIN {
  # Create constant subs for each log level (to export).
  for (LOG_LEVELS) {
    no strict 'refs';
    *{join('::', __PACKAGE__, $_)} = eval "sub() { LOG_LEVEL->{$_} }";
  }

  # Create constant subs for each log facility (to export).
  for (LOG_FACILITIES) {
    no strict 'refs';
    my $name = lc substr($_, 4);
    *{join('::', __PACKAGE__, $_)} = sub { $name };
  }

  push @EXPORT,    qw( Log Logf );
  push @EXPORT_OK, LOG_LEVELS;
  push @EXPORT_OK, LOG_FACILITIES;
  $EXPORT_TAGS{log_levels}        = [ LOG_LEVELS ];
  $EXPORT_TAGS{syslog_facilities} = [ LOG_FACILITIES ];
}

sub __dump_levels{
  my ($max) = sort { $b <=> $a } map length, LOG_LEVELS;
  printf "%${max}s  % 02d\n", $_, LOG_LEVEL->{$_}
    for LOG_LEVELS;
}

# -------------------------------------

use constant SINK_STDERR      => ':stderr';

use constant DEFAULT_CHANNELS => qw( CHAN_PROGRESS CHAN_DEBUG
                                     CHAN_STATS    CHAN_INFO );

BEGIN {
  for (DEFAULT_CHANNELS) {
    no strict 'refs';
    # Prefix with ':' to make illegal name (for anyone else!)
    # (to avoid namespace clash)
    my $name = ':' . lc substr($_, 5);
    *{join('::', __PACKAGE__, $_)} = sub { $name };
  }

  push @EXPORT_OK, DEFAULT_CHANNELS, 'SINK_STDERR';
  $EXPORT_TAGS{default_channels}        = [ DEFAULT_CHANNELS, 'SINK_STDERR' ];
}

# -------------------------------------

# FOR TESTING
our ($__SINK_TERM_FORCE) = 0;

my ($last_time, $last_now);
sub SINK_TERM_PROGRESS {
  eval "use Term::ProgressBar 2.00;";
  croak sprintf("Cannot use sink %s without Term::ProgressBar present:\n  %s",
                (caller 0)[3], $@)
    if $@;

  my ($fh, $level) = @_;

  my $fn;
  if ( defined $fh ) {
    if ( ! ref $fh ) {
      $fn = $fh;
      CORE::sysopen $fh, $fn, O_WRONLY
          or croak "Cannot open $fh for writing: $!\n";
    }
  } else {
    $fh = \*STDERR;
  }

  Term::ProgressBar->__force_term($__SINK_TERM_FORCE)
      if $__SINK_TERM_FORCE;
  if ( $__SINK_TERM_FORCE || -t $fh ) {
    my ($next) = (0);
    my $progress = Term::ProgressBar->new({count => 100,
                                           fh    => $fh,
                                           ETA   => 'linear'});
    return 'SUBR', undef,
           { subr => sub {
               if ( my ($prefix, $now, $end, $percent, $suffix) =
                    ($_[0] =~ m!(.*)
                                                                \[(?:([\d_,.]+)/([\d_,.]+)  |
                                                                          (?:([\d_,.]+)%))
                                                                    (?:\s+[^]]*)?\s+Done\]
                                                                (.*)!x) ) {
                 tr/_,//d
                   for grep defined, $now, $end, $percent;

                 ($now, $end) = ($percent, 100)
                   if defined $percent;

                 my $message_printed = 0;

                 if ( defined $suffix and $suffix !~ /^\s*$/ ) {
                   s!^\s*(.*?)\s*$!$1!
                     for grep defined, $suffix, $prefix;
                   if ( defined $prefix and $prefix !~ /^\s*$/ ) {
                     $progress->message("$prefix $suffix");
                   } else {
                     $progress->message($suffix);
                   }

                   $message_printed = 1;
                 }

                 if ( $end != $progress->target ) {
                   $progress->target($end);
                   $next = $progress->update($now)
                 } else {
                   $next = $progress->update($now)
                     if($message_printed                  or
                        $now >= $next                     or
                        time >= $last_time + ETA_ACCURACY ) ;
                 }

                 $last_now = $now;
               } else {
                 $progress->message($_[0]);
                 $progress->update($last_now);
               }
             $last_time = time;
           }
         };
  } else {
    if ( defined $fn ) {
      return 'FILE', $level, { fn => $fh };
    } else {
      return 'FH',   $level, { fh => $fh };
    }
  }
}

# -------------------------------------

use constant TRANS_UDT =>
  sub { my $time = time;
        sprintf('[%d %s] %s',
                $time, scalar gmtime $time, $_[0]) };

{ # Very unpleasant hackery to discern timezone offset on systems with backward
  # strftimes.  Bloody Solaris.

  my $save = $!+0;

  my $format = '(%d%b %H:%M:%S%z)';
  my $check = strftime('%z',localtime);
  if ( $check eq '%z' ) {
    $format = undef;

  ATTEMPT:
    # sfw for recent Solaris boxen
    for my $path (@PATH, '/opt/sfw/bin') {
      for my $dname (qw( date gdate )) {
        my $date = catfile $path, $dname;
        next
          unless -x $date;

#         pipe my ($read, $write);
#         die "fork failed: $!\n"
#           unless defined (my $pid = fork);
#
#         if ( $pid ) { # Parent
#           close $write;
#           print STDERR $_
#             for <$read>;
#         } else {      # Child
#           close $read;
#           open STDOUT, '>&=', fileno $write;
#           open STDERR, '>&=', fileno $write;
#
#           exec $date, '--version';
#         }

        my $date_version = qx( $date --version 2>&1 );
        {
          local $/ = undef;
          open *DATE, "$date --version 2>&1 |";
          $date_version = <DATE>;
          # Don't check the return code; it'll often be >0 since we're
          # running a utility (--version)
          CORE::close *DATE;
        }

        if ( $date_version =~ m/^date \(GNU.*\) ([\d.]+)$/m ) {
          (my $version = $1);
          my @v = split /\./, $version;
          $version = join('.', $v[0],
                          join '', map sprintf('%03d', $_), @v[1..$#_]);
          if ( $version >= 2 ) {
            chomp(my $timezone = qx( $date +%z ));
            $format   = "(%d%b %H:%M:%S$timezone)";
            last ATTEMPT;
          } # end if ( $version >= 2 )
        } # end if ( $date_version =~ m/^date \(GNU.*\) ([\d.]+)$/m )
      } # for my $dname (qw( date gdate ))
    } # end for my $path (@PATH)

    # A questionable llseek on Solaris leaves ESPIPE in $!
    $! = $save;
  } # end if ( $check eq '%z' )

  use constant TRANS_CDT =>
    sub { my $time = time;
          die "Cannot determine timezone info.  Sorry.  Perhaps installing gnu date will help\n"
            unless defined $format;
          sprintf('[%d%s:%s] %s',
                  $time,
                  strftime($format, localtime($time)),
                  $0, $_[0]); };
}

# -------------------------------------

our $PACKAGE = 'Log-Info';
our $VERSION = '1.21';

# -------------------------------------
# PACKAGE CONSTRUCTION
# -------------------------------------

# -------------------------------------
# PACKAGE DESTRUCTION
# -------------------------------------

END {
  delete_channel($_)
    for keys %channel;
}

# -------------------------------------
# PACKAGE COMPONENTS
# -------------------------------------

# Channels -------------------------------------------------------------------

# Map from channel name to details.
# Each detail is a hashref, with the following keys:
#   sinks   ) Hashref of data sinks, by name.  The name itself is for
#             identifying the sink for adding, removing, altering.  It has no
#             semantic value.
#             Each sink is itself a hashref, with keys:
#               type    )
#                  Currently recognized types are
#                    FILE    )
#                      Values recognized:
#                        fn      ) (base) filename
#                        maxsize ) max file size
#                        fh      ) open fh, if previously used.  This is
#                                  generated and used by Log() directly; do
#                                  not manhandle.
#                    FH      )
#                        fh      ) open fh.  May be an IO thing (*FOO{IO}),
#                                  a glob ref, a glob, or an instance of
#                                  IO::Handle
#                    SUBR    )
#                        subr    ) a subroutine that will be invoked with the
#                                  log text as its single argument.
#               values  )
#                  Hashref with Type-specific keys; see the (type)
#                  documentation
#               trans   )
#                  If defined, a translation applied for the sink.  This is
#                  aplied to the result of any channel-specific translation.
#               level   )
#                  If defined, a level cutoff for the sink.  This level is
#                  checked only if the channel level is passed; hence, a level
#                  greater than or equal to the channel level has no effect.
#   trans   ) Arrayref of sub refs for channel data translators.  Each array
#             member is applied in order, list head first, with cumulative
#             results.
#   level   ) Number for channel level output cutoff

sub add_channel {
  my ($chan, $level) = @_;

  $level = LOG_NOTICE()
    unless @_ >= 2;

  croak "Invalid channel name :->$chan<-\n"
    unless $chan =~ /^[\w-]+$/ or caller eq __PACKAGE__;

  croak "Channel already exists: $chan\n"
    if exists $channel{$chan};

  $channel{$chan} = { sinks => {},
                      level => $level,
                    };
}

BEGIN {
  add_channel(eval "$_", undef)
    for DEFAULT_CHANNELS;
}

# -------------------------------------

sub delete_channel {
  my ($chan) = @_;

  croak "Channel does not exist: $chan\n"
    unless exists $channel{$chan};

  delete_sink($chan, $_)
    for keys %{$channel{$chan}{sinks}};
  delete $channel{$chan};
}

# -------------------------------------

sub channel_exists { return exists $channel{$_[0]} }

# -------------------------------------

sub set_channel_out_level {
  my ($chan, $level) = @_;

  croak "Channel does not exist: $chan\n"
    unless exists $channel{$chan};
  $level = get_level($level);

  $channel{$chan}->{level} = $level;
}

# -------------------------------------

sub add_chan_trans {
  my ($chan, $trans) = @_;

  croak "Channel does not exist: $chan\n"
    unless exists $channel{$chan};
  croak sprintf("Translator for channel %s not a subroutine: %s\n",
                $chan, ref $trans || $trans)
    unless UNIVERSAL::isa ($trans, 'CODE');

  push @{$channel{$chan}{trans}}, $trans;
}

# Sinks ----------------------------------------------------------------------

# -------------------------------------

my $syslog_initialized = 0;

use constant REQUIRED_PARAMS =>
  {
   FILE   => [ qw( fn ) ],
   FH     => [ qw( fh ) ],
   SUBR   => [ qw( subr )],
   SYSLOG => [ ],
  };

sub add_sink {
  my ($chan, $name, $type, $level, $params) = @_;

  croak "Channel does not exist: $chan\n"
    unless exists $channel{$chan};
  croak sprintf("params arg must be hashref, not %s\n", ref $params)
    if defined $params and not UNIVERSAL::isa($params, 'HASH');

  croak "Invalid sink name :->$name<-\n"
    unless $name =~ /^[\w-]+$/ or caller eq __PACKAGE__;

  my %values;

  my $required_params = REQUIRED_PARAMS->{$type};
  croak "Unrecognized sink type: $type\n"
    unless defined $required_params;
  croak sprintf ("%s undefined for %s sink type; channel/sink %s/%s\n",
                 $_, $type, $chan, $name)
    for grep ! defined $params->{$_}, @$required_params;

  if ( $type eq 'FILE' ) {
    @values{qw( fn maxsize )} = @{$params}{qw( fn maxsize )};
    $values{maxsize} = 1_024 ** 3 # 1Gb
      unless defined $values{maxsize};
    croak
      sprintf ("maxsize must be greater than 0 for channel/sink %s/%s: %s\n",
               $chan, $name, $values{maxsize})
        unless $values{maxsize} > 0;
  } elsif ( $type eq 'FH' ) {
    $values{fh}               = $params->{fh};
    croak
      sprintf ("fh type not acceptable for channel/sink %s/%s: %s\n",
               $chan, $name, ref $values{fh})
        unless UNIVERSAL::isa ($values{fh}, 'IO::Handle')
            or UNIVERSAL::isa ($values{fh}, 'GLOB');
  } elsif ( $type eq 'SUBR' ) {
    $values{subr}             = $params->{subr};
    croak
      sprintf ("subr type not acceptable for channel/sink %s/%s: %s\n",
               $chan, $name, ref $values{subr})
        unless UNIVERSAL::isa ($values{subr}, 'CODE');
  } elsif ( $type eq 'SYSLOG' ) {
    $values{facility} = $params->{facility};

    {
      no strict 'refs';
      croak
        sprintf ("facility '%s' unrecognized for channel/sink %s/%s\n",
                 $values{facility}, $chan, $name)
          if defined $values{facility} and
            ! grep &$_ eq $values{facility}, LOG_FACILITIES;
    }

    unless ( $syslog_initialized ) {
      setlogsock 'unix';
      openlog $Script, 'cons,pid', 'user';
      $syslog_initialized = 1;
    }
  } else {
    croak "Unrecognized sink type: $type\n";
  }

  my $sink = { type   => $type,
               level  => $level,
               values => \%values,
             };

  $channel{$chan}{sinks}{$name} = $sink;
}

BEGIN {
  add_sink(CHAN_INFO, SINK_STDERR, 'FH', LOG_WARNING, { fh => *STDERR{IO} });
}

# -------------------------------------

sub delete_sink {
  my ($chan, $sink) = @_;

  croak "Channel does not exist: $chan\n"
    unless exists $channel{$chan};
  croak "Channel/Sink does not exist: $chan/$sink\n"
    unless exists $channel{$chan}{sinks}{$sink};

  if ( $channel{$chan}{sinks}{$sink}{type} eq 'FILE' ) {
    if ( defined $channel{$chan}{sinks}{$sink}{values}{fh} ) {
      $channel{$chan}{sinks}{$sink}{values}{fh}->close
      or warn sprintf("Log::Info::delete_sink : " .
                      "Close failed on filehandle for channel/sink/filename " .
                      "%s/%s/%s: $!",
                      $chan, $sink, $channel{$chan}{sinks}{$sink}{values}{fn});
    }
  }

  delete $channel{$chan}{sinks}{$sink};
}

# -------------------------------------

sub set_sink_out_level {
  my ($chan, $sink, $level) = @_;

  croak "Channel does not exist: $chan\n"
    unless exists $channel{$chan};
  croak "Channel/Sink does not exist: $chan/$sink\n"
    unless exists $channel{$chan}{sinks}{$sink};
  $level = get_level($level);

  $channel{$chan}{sinks}{$sink}{level} = $level;
}

# -------------------------------------

sub add_sink_trans {
  my ($chan, $sink, $trans) = @_;

  croak "Channel does not exist: $chan\n"
    unless exists $channel{$chan};
  croak "Channel/Sink does not exist: $chan/$sink\n"
    unless exists $channel{$chan}{sinks}{$sink};
  croak sprintf("Translator for %s/%s not a subroutine: %s\n",
                $chan, $sink, ref $trans)
    unless UNIVERSAL::isa ($trans, 'CODE');

  push @{$channel{$chan}{sinks}{$sink}{trans}}, $trans;
}

# -------------------------------------
# PACKAGE FUNCTIONS
# -------------------------------------

sub get_level {
  my ($level) = @_;

  return
    unless defined $level;

  if ( $level !~ /^-?\d+/ ) {
    if ( exists LOG_LEVEL->{$level} ) {
      $level = LOG_LEVEL->{$level};
    } else {
      croak "unrecognized level: $level\n";
    }
  }

  return $level;
}

# -------------------------------------

sub Log {
  my ($channel, $level, $string) = @_;

  croak "Log::Info::Log : unrecognized channel: $channel\n"
    unless exists $channel{$channel};
  $level = get_level($level);

  if ( ! defined $string ) {
    my @caller = caller 1;
    $string =
      sprintf('Log::Info::Log *UNDEFINED* (called by %s::%s, at %s line %d)',
              @caller[0,3,1,2]);
  }

  my $details = $channel{$channel};

  return
    unless (( ! defined $channel{$channel}{level}
              or
              $level <= $channel{$channel}{level} )
            and %{$details->{sinks}}
            and grep({ my $sl = $details->{sinks}->{$_}->{level};
                       ! defined $sl || $level <= $sl; }
                     keys %{$details->{sinks}}));

  if ( exists $details->{trans} ) {
    my $i = 0;
    my @trans = @{$details->{trans}};
    while ( $i < @trans ) {
      eval {
        $string = $trans[$i]->($string);
      }; if ( $@ ) {
        warn ("Log::Info::Log : ",
              "Bad translation unit ($i) for channel $channel: $@\n");
      }
      $i++;
    }
  }

 SINK:
  while ( my ($name, $sink) = each %{$details->{sinks}} ) {
    next SINK
      if $name eq SINK_STDERR and $dying;

    my ($type, $sinklevel, $trans, $values) =
      @{$sink}{qw( type level trans values )};

    # Are we below the requisite level?
    next SINK
      if defined $sinklevel and $level > $sinklevel;

    # Any further translations?
    my $sinkstring = $string;
    if ( defined $trans ) {
      my $i = 0;
      my @trans = @$trans;
      while ( $i < @trans ) {
        eval {
          $sinkstring = $trans[$i]->($sinkstring);
        }; if ( $@ ) {
          warn (sprintf ("Log::Info::Log : Bad translation unit " .
                         "(%d) for channel %s sink %s: $@\n",
                         $i, $channel, $name));
        }
        $i++;
      }
    }

    if ( $type eq 'FILE' ) {
      _log_to_file   ($values, $sinkstring, $channel, $name, $level);
    } elsif ( $type eq 'FH' ) {
      _log_to_fh     ($values, $sinkstring, $channel, $name, $level);
    } elsif ( $type eq 'SUBR' ) {
      _log_to_subr   ($values, $sinkstring, $channel, $name, $level);
    } elsif ( $type eq 'SYSLOG' ) {
      _log_to_syslog ($values, $sinkstring, $channel, $name, $level);
    } else {
      warn ("Log::Info::Log : Bad sink type ($type) for channel/name ",
            "$channel/$name\n");
    }
  }
}

# -------------------------------------

sub Logf {
  my ($channel, $level, $format, @args) = @_;

  if ( ! exists $channel{$channel} ) {
    carp "Log::Info::Log : unrecognized channel: $channel\n";
    return;
  }

  if ( ! defined $format ) {
    my @caller = caller 1;
    Log ($channel, $level,
         sprintf('Log::Info::Logf: sprintf format not defined ' .
                 '(called by %s::%s, at %s line %d)',
                 @caller[0,3,1,2]));
    return;
  }

  if ( grep ! defined, @args ) {
    my @caller = caller 1;
    for (grep ! defined $args[$_], 0..$#args) {
      Log ($channel, $level,
           sprintf('Log::Info::Logf: format argument %s not defined ' .
                   '(called by %s::%s, at %s line %d)',
                   $_, @caller[0,3,1,2]));
      $args[$_] = '';
    }
  }

  Log ($channel, $level, sprintf $format, @args);
}

# Subroutines picked out from log to simplify things

sub _log_to_file {
  my ($values, $sinkstring, $channel, $name, $level) = @_;

  my ($logfn, $maxsize, $fh) = @{$values}{qw( fn maxsize fh )};
  local $/ = "\n"; chomp $sinkstring;
  $sinkstring .= "\n";

SIZE_CHECK:
  while (1) {
    if ( defined $fh ) {
      # Check if write to fh would take size past max; if so, close fh,
      # move name to unused old name, and undefine $fh to get new one
      # generated

      # tell() doesn't work for appended filehandles :-(
      my $fsize = (stat $fh)[7];
      my $new_size = $fsize + length $sinkstring;
      if ( $new_size > $maxsize and $fsize ) { # If this is this first
                                               # message, log it whatever
        $fh->close
          or warn("Log::Info::Log : ",
                  "Failure to close output log $logfn: $!\n");
        my ($dd, $mm, $yy) = (gmtime)[3..5];
        my $tname = sprintf ("%s-%d-%02d-%02d", $logfn,
                             $yy+1900, $mm+1, $dd);
        my $tail = '00';
        $tail++
          while -e join '-', $tname, $tail;
        rename $logfn, join '-', $tname, $tail
          or warn sprintf ("Log::Info::Log : " .
                           "Failure to rename output log %s to %s: $!\n",
                           $logfn, join '-', $tname, $tail);
        $fh = undef;
        delete $values->{fh};
      } else {
        last SIZE_CHECK;
      }
    }

    if ( ! defined $fh ) {
      # Open a shiny new fh, and assign it to fh
      if ( sysopen $fh, $logfn, O_WRONLY | O_APPEND | O_CREAT ) {
        $values->{fh} = $fh;
      } else {
        warn "Log::Info::Log : Couldn't open $logfn for appending: $!\n";
        delete_sink ($channel, $name);
        last SIZE_CHECK;
      }
    }
  }

  # Write the output!
  if ( defined $fh ) {
    $fh->syswrite($sinkstring)
      or warn sprintf ("Log::Info::Log : " .
                       "Print failed on file %s (name/chan %s/%s): $!\n",
                       $logfn, $name, $channel);
  }
}

# -------------------------------------

sub _log_to_fh {
  my ($values, $sinkstring, $channel, $name, $level) = @_;

  local $/ = "\n"; chomp $sinkstring;
  eval {
    $values->{fh}->syswrite("$sinkstring\n")
      or warn sprintf ("Log::Info::Log : " .
                       "Print failed on filehandle %s (channel %s): $!\n",
                       $name, $channel);
  }; if ( $@ ) {
    warn("Log::Info::Log : " .
         "Print to filehandle $name on channel $channel failed:\n  $@\n");
  }
}

# -------------------------------------

sub _log_to_subr {
  my ($values, $sinkstring, $channel, $name, $level) = @_;

  eval {
    $values->{subr}->($sinkstring);
  }; if ( $@ ) {
    warn("Log::Info::Log : " .
         "Invocation of subr $name on channel $channel failed:\n  $@\n");
  }
}

# -------------------------------------

sub _log_to_syslog {
  my ($values, $sinkstring, $channel, $name, $level) = @_;

  my $sysloglevel = LOG_NAME->{$level};

  if ( defined $values->{facility} ) {
    $sysloglevel = join '|', $values->{facility}, $sysloglevel;
  }

  if ( ! defined $sysloglevel ) {
    # Bump level up to next defined level
  LOG_LEVEL:
    foreach (LOG_LEVEL_VALUES) {
      if ( $_ < $level ) {
        $sysloglevel = LOG_NAME->{$_};
      } else { # $_ > $level
               # $_ != $level because ! defined $sysloglevel on loop entry
        last LOG_LEVEL; # LOG_LEVEL_VALUES is sorted; hence all successive
                        # values will also be > $level
      }
    }
  }

  if ( ! defined $sysloglevel ) {
    # Looks like none of the values are higher.  Default to LOG_EMERG.
    # call LOG_EMERG, then deref, just to check it's a valid level
    $sysloglevel = LOG_NAME->{LOG_EMERG()};
  }

  # Unset log mask
  my $oldmask = setlogmask (Sys::Syslog::LOG_UPTO(Sys::Syslog::LOG_DEBUG));
  syslog $sysloglevel, $sinkstring;
  setlogmask ($oldmask);
}


# -------------------------------------
# PACKAGE PROCEDURES
# -------------------------------------

sub import {
  my $class = shift;
  my (@bad_names, @export_symbols);
  my %export_ok = map({; $_ => 1 }
                      ':DEFAULT', @EXPORT, @EXPORT_OK,
                      map(":$_", keys %EXPORT_TAGS));
  for (@_) {
    if ( $_ eq ':trap' ) {
      __trap_warn_die();
    } elsif ( exists $export_ok{$_} ) {
      push @export_symbols, $_;
    } else {
      push @bad_names, $_;
    }
  }

  croak ("Arguments to " . __PACKAGE__ .
         " import  not recognized: ",
         join (', ', @bad_names), "\n")
    if @bad_names;

  $class->export_to_level(1, $class, @export_symbols);

}

my %redef_subr = (die => 1); # track of subrs intentionally redefined to
                             # exclude from warnings
sub trap_warn_die {
  Log(CHAN_INFO, LOG_WARNING,
      "trap_warn_die subr deprecated; use the import tag :trap instead\n");
  __trap_warn_die();
}

sub __trap_warn_die {

  my $lastmessage = '';

  my $package;
  {
    my $i = 0;
    do {
      ($package) = (caller($i))[0];
      $i++;
    } while ( $package eq __PACKAGE__ );
  }

  my $file = __FILE__;
  my $warnhook = $SIG{__WARN__};

  $SIG{__WARN__} = sub {
    # Nasty hack to avoid irritating mandatory redefine warnings bug
    if ( my ($subrname) = ($_[0] =~ /^Subroutine ([:\w]+) redefined at $file/ )
       ) {
      if ( exists $redef_subr{$subrname}             or
           ( index($subrname,':') == -1 and
             exists $redef_subr{"main::$subrname"} ) or
           ( $subrname =~ /^(?:main|CORE::GLOBAL)::([a-z_]\w+)$/ and
             exists $redef_subr{$1} )
         ) {
        return;
      }
    }
    my $message = join '', grep defined, @_;
    Log(CHAN_INFO, LOG_WARNING, $message);
    $warnhook->(@_)
      if defined $warnhook and UNIVERSAL::isa($warnhook, 'CODE');
  };

  my $save;

  my $diehook = $SIG{__DIE__};
  # Carp doesn't call die directly.  In know not how or why.  So this traps
  # calls to carp that didn't make it via the override
  $SIG{__DIE__} = sub {
    local $dying = 1;
    my $message = join '', grep defined, @_;
      if ( $message !~ /\A[\s\n]*\Z/ ) {
        Log(CHAN_INFO, LOG_ERR, $message)
          unless $message eq $lastmessage;
      }
    $diehook->(@_)
      if defined $diehook and UNIVERSAL::isa($diehook, 'CODE');
    $! = $save
      if $save;
  };

  # Override Carp messages if present
  for (qw( croak confess )) {
    no strict 'refs';
    my $subr_name = defined $package ? "${package}::$_" : "main::$_";
    my $subr = \&{$subr_name};
    if ( defined $subr ) {
      $redef_subr{$subr_name} = $redef_subr{$_} = 1;
      *{"$subr_name"} = sub {
        $save = $!+0;
        $subr->(@_);
      };
    }
  }

  *CORE::GLOBAL::die =
    sub {
      local $dying = 1;
      $save = $! + 0;
      my $message = join '', grep defined, @_;
      if ( $message !~ /\A[\s\n]*\Z/ ) {
        # Always terminate with a newline.  This ensures conformity of message
        # with that checked in SIG{__DIE__}, which otherwise may have an
        # "\n  at line..." appended.
        # If we want such appendages, we can add them ourselves
        $message =~
          s/([^\n])\z/sprintf("%s at %s line %d", $1, (caller)[1,2]) . "\n"/e;
        $message =~ s/\n+\z/\n/;
        Log(CHAN_INFO, LOG_ERR, $message)
          unless $message eq $lastmessage;
        $lastmessage = $message;
      }
      $! = $save
        if $save;
      CORE::die("$message");
    };

}

# -------------------------------------

my %seen_channel_sink;
sub enable_file_channel {
  my ($channel_name, $fn, $option_name, $sink_name, $term_progress) = @_;

  if ( defined $fn ) { # Else option not invoked
    $fn =~ s/\s*(.*?)\s*$/$1/;
    my $fh;

    my $level = LOG_INFO;
    if ( $fn =~ s/\+(\d+)// or $fn =~ s/^(\d+)$// ) {
      $level += $1-1;
    } else {
      my $key = join "\0", $channel_name, $sink_name;
      $level += $seen_channel_sink{$key}++;
    }

    if ( $fn eq '' ) {
      $fh = \*STDERR;
    } elsif ( substr($fn, 0, 1) eq ':' ) {
      my $fd = substr($fn, 1);
      if ( $fd =~ /^\d+/ ) {
        unless ( CORE::open $fh, ">&=$fd" ) {
          # Don't use Log::Info when the channels haven't opened...
          croak "Could not open file descriptor $fd for writing: $!\n";
        }
        select (((select $fh), $| = 1)[0]);
      } else {
        croak sprintf("Cannot handle non-integer file descriptor " .
                      "argument to %s: %s", $option_name, $fn);
      }
    } elsif ( $fn =~ m!^[A-Za-z0-9_.\\/-]+$! ) {
      unless ( CORE::sysopen $fh, $fn, O_CREAT | O_EXCL | O_WRONLY ) {
        croak "Could not open file $fn for (create &) writing: $!\n";
      }
    } else {
      croak "Cannot handle argument to $option_name: $fn\n";
    }

    if ( defined $fh ) {
      if ( $term_progress ) {
        add_sink($channel_name, $sink_name, SINK_TERM_PROGRESS($fh, $level));
      } else {
        add_sink($channel_name, $sink_name, 'FH', $level, { fh => $fh });
      }
    }

    return $level - (LOG_INFO - 1);
  }
}

# ----------------------------------------------------------------------------

1; # keep require happy.

__END__