File Coverage

blib/lib/Term/Emit.pm

Criterion	Covered	Total	%
statement	321	356	90.1
branch	162	212	76.4
condition	70	98	71.4
subroutine	34	48	70.8
pod	25	25	100.0
total	612	739	82.8

# Term::Emit - Print with indentation, status, and closure
#
#  $Id: Emit.pm 395 2012-09-06 18:21:50Z steve $

package Term::Emit;
use warnings;
use strict;
use 5.008;

use Exporter;
use base qw/Exporter/;
use Scope::Upper 0.06 qw/:words reap/;

our $VERSION   = '0.0.4';
our @EXPORT_OK = qw/emit emit_over emit_prog emit_text emit_done emit_none
    emit_emerg
    emit_alert
    emit_crit emit_fail emit_fatal
    emit_error
    emit_warn
    emit_note
    emit_info emit_ok
    emit_debug
    emit_notry
    emit_unk
    emit_yes
    emit_no/;
our %EXPORT_TAGS = (all => [@EXPORT_OK]);

use constant MIN_SEV => 0;
use constant MAX_SEV => 15;
our %SEVLEV = (
    EMERG => 15,
    ALERT => 13,
    CRIT  => 11,
    FAIL  => 11,
    FATAL => 11,
    ERROR => 9,
    WARN  => 7,
    NOTE  => 6,
    INFO  => 5,
    OK    => 5,
    DEBUG => 4,
    NOTRY => 3,
    UNK   => 2,
    OTHER => 1,
    YES   => 1,
    NO    => 0,
);
our %BASE_OBJECT = ();

sub new {
    my $proto = shift;
    my $class = ref($proto) || $proto;    # Get the class name
    my $this  = {
        pos     => 0,                     # Current output column number
        progwid => 0,                     # Width of last progress message emitted
        msgs    => []
    };    # Closing message stack
    bless $this, $class;
    $this->setopts(@_);
    return $this;
}

sub base {
    my ($this) = _process_args(@_);
    return $this;
}

sub clone {
    my $this = shift;    # Object to clone
    return Term::Emit->new(%{$this}, _clean_opts(@_));
}

sub import {
    my $class = shift;

    # Yank option sets, if any, out from the arguments
    my %opts = ();
    my @args = ();
    while (@_) {
        my $arg = shift;
        if (ref($arg) eq 'HASH') {
            %opts = (%opts, %{$arg});    #merge
            next;
        }
        push @args, $arg;
    }
    %opts = _clean_opts(%opts);

    # Create the default base object
    $BASE_OBJECT{0} ||= new Term::Emit(%opts);

    # Continue exporter's work
    return $class->export_to_level(1, $class, @args);
}

#
# Set options
#
sub setopts {
    my ($this, $opts, %args) = _process_args(@_);

    # Merge & clean 'em
    %args = (%{$opts}, %args);
    %args = _clean_opts(%args);    ###why does this not work here?? -fh vs fh

    # Process args
    my $deffh = select();
    no strict 'refs';
    $this->{fh}
        = $args{fh}
        || $this->{fh}
        || \*{$deffh};
    use strict 'refs';
    $this->{envbase}
        = $args{envbase}
        || $this->{envbase}
        || 'term_emit_fd';    ### TODO: apply to all envvars we use, not just _fd
    $this->{bullets}
        = exists $ENV{term_emit_bullets} ? $ENV{term_emit_bullets}
        : exists $args{bullets}          ? $args{bullets}
        : exists $this->{bullets}        ? $this->{bullets}
        :                                  0;
    $this->{closestat}
        = $args{closestat}
        || $this->{closestat}
        || 'DONE';
    $this->{color}
        = exists $ENV{term_emit_color}
        ? $ENV{term_emit_color}
        : $args{color}
        || $this->{color}
        || 0;
    $this->{ellipsis}
        = exists $ENV{term_emit_ellipsis}
        ? $ENV{term_emit_ellipsis}
        : $args{ellipsis}
        || $this->{ellipsis}
        || '...';
    $this->{maxdepth}
        = exists $ENV{term_emit_maxdepth} ? $ENV{term_emit_maxdepth}
        : exists $args{maxdepth}          ? $args{maxdepth}
        :   $this->{maxdepth};    #undef=all, 0=none, 3=just first 3 levels, etc
    $this->{showseverity}
        = exists $ENV{term_emit_showseverity} ? $ENV{term_emit_showseverity}
        : exists $args{showseverity}          ? $args{showseverity}
        :                                  $this->{showseverity};
    $this->{step}
        = exists $ENV{term_emit_step} ? $ENV{term_emit_step}
        : exists $args{step}          ? $args{step}
        : defined $this->{step}       ? $this->{step}
        :                               2;
    $this->{timestamp} = $args{timestamp}
        || $this->{timestamp}
        || 0;
    $this->{trailer}
        = exists $ENV{term_emit_trailer}
        ? $ENV{term_emit_trailer}
        : $args{trailer}
        || $this->{trailer}
        || q{.};
    $this->{width}
        = exists $ENV{term_emit_width}
        ? $ENV{term_emit_width}
        : $args{width}
        || $this->{width}
        || 80;

    #    $this->{timefmt}   = $args{timefmt}   || $this->{timefmt}   || undef;   # Timestamp format
    #    $this->{pos} = $args{pos}
    #        if defined $args{pos};

    # Recompute a few things
    # TODO: Allow bullets to be given as CSV:  "* ,+ ,- ,  " for example.
    # TODO: Put this in a sub of its own.
    $this->{bullet_width} = 0;
    if (ref $this->{bullets} eq 'ARRAY') {
        foreach my $b (@{$this->{bullets}}) {
            $this->{bullet_width} = length($b)
                if length($b) > $this->{bullet_width};
        }
    }
    elsif ($this->{bullets}) {
        $this->{bullet_width} = length($this->{bullets});

        return 0;
    }
}

#
# Emit a message, starting a new level
#
sub emit {
    my ($this, $opts, @args) = _process_args(@_);
    my $jn = defined $, ? $, : q{};
    if (@args && ref($args[0]) eq 'ARRAY') {

        # Using [opentext, closetext] notation
        my $pair  = shift @args;
        my $otext = $pair->[0] || '';
        my $ctext = $pair->[1] || $otext;
        unshift @args, $otext;
        $opts->{closetext} = $ctext;
    }
    my $msg = join $jn, @args;
    if (!@args) {

        # Use our caller's subroutine name as the message
        (undef, undef, undef, $msg) = caller(1);
        $msg =~ s{^main::}{}sxm;
    }

    #  Tied closure:
    #   If we're returning into a list context,
    #   then we're tying closure to the scope of the caller's list element.
    return Term::Emit::TiedClosure->new($this, $opts, $msg)
        if wantarray;

    # Store context
    my $cmsg
        = defined $opts->{closetext}
        ? $opts->{closetext}
        : $msg;
    push @{$this->{msgs}}, [$msg, $cmsg];
    my $level = $ENV{$this->_envvar()}++ || 0;

    # Setup the scope reaper for autoclosure
    reap sub {
        $this->emit_done({%{$opts}, want_level => $level}, $this->{closestat});
    } => SCOPE(1);

    # Filtering by level?
    return 1
        if defined($this->{maxdepth}) && $level >= $this->{maxdepth};

    # Start back at the left
    my $s = 1;
    $s = $this->_spew("\n")
        if $this->{pos};
    return $s unless $s;
    $this->{pos}     = 0;
    $this->{progwid} = 0;

    # Level adjust?
    $level += $opts->{adjust_level}
        if $opts->{adjust_level} && $opts->{adjust_level} =~ m{^-?\d+$}sxm;

    # Timestamp
    my $tsr = defined $opts->{timestamp}? $opts->{timestamp} : $this->{timestamp};
    $tsr = \&_timestamp if $tsr && !ref($tsr);
    my $ts = $tsr? &$tsr($level) : q{};

    # The message
    my $bullet = $this->_bullet($level);
    my $indent = q{ } x ($this->{step} * $level);
    my $tlen   = 0;
    my $span   = $this->{width} - length($ts) - length($bullet) - ($this->{step} * $level) - 10;
    my @mlines = _wrap($msg, int($span * 2 / 3), $span);
    while (defined(my $txt = shift @mlines)) {
        $s = $this->_spew($ts . $bullet . $indent . $txt);
        return $s unless $s;
        $s = $this->_spew(@mlines ? "\n" : $this->{ellipsis});
        return $s unless $s;
        $tlen   = length($txt);
        $bullet = q{ } x $this->{bullet_width};    # Only bullet the first line
        $ts     = q{ } x length($ts);              # Only timestamp the first line
    }
    $this->{pos} += length($ts) + ($this->{step} * $level) + length($bullet) + $tlen + length($this->{ellipsis});
    return 1;
}

#
# Complete the current level, with status
#
sub emit_done {
    my ($this, $opts, @args) = _process_args(@_);
    my $want_level = $opts->{want_level};
    my $sev        = shift @args || 'DONE';
    my $sevlev     = defined $SEVLEV{uc $sev}? $SEVLEV{uc $sev} : $SEVLEV{'OTHER'};

    # Test that we're at the right level - do this BEFORE changing the envvar
    my $ret_level = ($ENV{$this->_envvar()} || 0) - 1;
    return
        if defined $want_level && $ret_level != $want_level;

    # Decrement level
    return $sevlev
        if !$ENV{$this->_envvar()};
    my $level = --$ENV{$this->_envvar()};
    delete $ENV{$this->_envvar()}
        if $level <= 0;

    # Filtering - level & severity
    my $showseverity
        = defined $opts->{showseverity}  ? $opts->{showseverity}
        : defined($this->{showseverity}) ? $this->{showseverity}
        :                             MAX_SEV;
    if (   $sevlev < $showseverity
        && defined($this->{maxdepth})
        && $level >= $this->{maxdepth})
    {
        pop @{$this->{msgs}};    # discard it
        return $sevlev;
    }

    # Are we silently closing this level?
    if ($opts->{silent}) {
        my $s = 1;
        $s = $this->_spew("\n")
            if $this->{pos};
        return $s unless $s;
        $this->{pos}     = 0;
        $this->{progwid} = 0;
        pop @{$this->{msgs}};    # discard it
        return $sevlev;
    }

    # Make the severity text
    my $sevstr = " [$sev]\n";
    my $slen   = 8;              # make left justified within max width 3+5
    $sevstr = " [" . _colorize($sev, $sev) . "]\n"
        if $this->{color};

    # Re-issue message if needed
    my $msgs = pop @{$this->{msgs}};
    my ($omsg, $cmsg) = @{$msgs};    # Opening and closing messages
                                     # -(if not the same, force a re-issue)-
    if ($this->{pos} && ($omsg ne $cmsg)) {
        # Closing differs from opening, so we need to re-issue with the closing
        my $s = $this->_spew("\n");
        return $s unless $s;
        $this->{pos} = 0;
    }
    if ($this->{pos}
        && defined($this->{maxdepth})
        && $level >= $this->{maxdepth}) {
        # This would be level-filtered, but severity overrode it, so we need to re-issue
        my $s = $this->_spew("\n");
        return $s unless $s;
        $this->{pos} = 0;
    }
    if ($this->{pos} == 0) {
        # Timestamp
        my $tsr = defined $opts->{timestamp}? $opts->{timestamp} : $this->{timestamp};
        $tsr = \&_timestamp if $tsr && !ref($tsr);
        my $ts = $tsr? &$tsr($level) : q{};

        my $bullet = $this->_bullet($level);
        my $indent = q{ } x ($this->{step} * $level);
        my $tlen   = 0;
        my $span   = $this->{width} - length($ts) - ($this->{step} * $level) - 10;
        my @mlines = _wrap($cmsg, int($span * 2 / 3), $span);
        while (defined(my $txt = shift @mlines)) {
            my $s;
            $s = $this->_spew($ts . $bullet . $indent . $txt);
            return $s unless $s;
            $s = $this->_spew("\n")
                if @mlines;
            return $s unless $s;
            $tlen   = length($txt);
            $bullet = q{ } x $this->{bullet_width};    # Only bullet the first line
            $ts     = q{ } x length($ts);              # Only timestamp the first line
        }
        $this->{pos} += length($ts) + length($bullet) + ($this->{step} * $level) + $tlen;
    }

    # Trailer
    my $ndots = $this->{width} - $this->{pos} - $slen;
    my $s     = 1;
    $s = $this->_spew($this->{trailer} x $ndots)
        if $ndots > 0;
    return $s unless $s;

    # Severity
    $s = $this->_spew($sevstr);
    return $s unless $s;
    $this->{pos} = 0;

    # Reason option?
    my $reason = $opts->{reason};
    $opts->{force} = 1; # Always give reason if we got thru above level filtering
    $s = emit_text($opts, $reason)
        if $reason;
    return $s unless $s;

    # Return with a severity value
    return $sevlev;
}

#
# Progress output
#
sub emit_over {
    my ($this, $opts, @args) = _process_args(@_);

    # Filtering by level?
    my $level = $ENV{$this->_envvar()} || 0;
    return 1
        if defined($this->{maxdepth}) && $level > $this->{maxdepth};

    # Erase prior progress output
    my $s = 1;
    $s = $this->_spew(qq{\b} x $this->{progwid});
    return $s unless $s;
    $s = $this->_spew(q{ } x $this->{progwid});
    return $s unless $s;
    $s = $this->_spew(qq{\b} x $this->{progwid});
    return $s unless $s;
    $this->{pos} -= $this->{progwid};
    $this->{progwid} = 0;

    return $this->emit_prog(@args);
}

sub emit_prog {
    my ($this, $opts, @args) = _process_args(@_);
    my $jn = defined $, ? $, : q{};
    my $msg = join $jn, @args;
    my $s;

    # Filtering by level?
    my $level = $ENV{$this->_envvar()} || 0;
    return 1
        if defined($this->{maxdepth}) && $level > $this->{maxdepth};

    # Start a new line?
    my $avail = $this->{width} - $this->{pos} - 10;
    if (length($msg) > $avail) {
        my $level  = $ENV{$this->_envvar()};
        my $bspace = q{ } x $this->{bullet_width};
        my $indent = q{ } x ($this->{step} * $level);
        $s = $this->_spew("\n");
        return $s unless $s;
        $s = $this->_spew($bspace . $indent);
        return $s unless $s;
        $this->{pos}     = length($bspace) + length($indent);
        $this->{progwid} = 0;
    }

    # The text
    $s = $this->_spew($msg);
    return $s unless $s;
    $this->{pos}     += length($msg);
    $this->{progwid} += length($msg);

    return 1;
}

#
# Issue additional info at the current level
#
sub emit_text {
    my ($this, $opts, @args) = _process_args(@_);
    my $jn = defined $, ? $, : q{};
    my $msg = join $jn, @args;

    # Filtering by level?
    my $level = $ENV{$this->_envvar()} || 0;
    return 1
        if !$opts->{force} && defined($this->{maxdepth}) && $level > $this->{maxdepth};

    # Start a new line
    my $s = 1;
    $s = $this->_spew("\n")
        if $this->{pos};
    return $s unless $s;

    # Level adjust?
    $level++;    # We're over by one by default
    $level += $opts->{adjust_level}
        if $opts->{adjust_level} && $opts->{adjust_level} =~ m{^-?\d+$}sxm;

    # Emit the text
    my $indent = q{ } x ($this->{step} * $level);
    my $span = $this->{width} - ($this->{step} * $level) - 10;
    my @mlines = _wrap($msg, int($span * 2 / 3), $span);
    while (defined(my $txt = shift @mlines)) {
        my $bspace = q{ } x $this->{bullet_width};
        $s = $this->_spew($bspace . $indent . $txt . "\n");
        return $s unless $s;
        $this->{pos} = 0;
    }
    return 1;
}

sub emit_emerg {emit_done @_, "EMERG"};    # syslog: Off the scale!
sub emit_alert {emit_done @_, "ALERT"};    # syslog: A major subsystem is unusable.
sub emit_crit  {emit_done @_, "CRIT"};     # syslog: a critical subsystem is not working entirely.
sub emit_fail  {emit_done @_, "FAIL"};     # Failure
sub emit_fatal {emit_done @_, "FATAL"};    # Fatal error
sub emit_error {emit_done @_, "ERROR"};    # syslog 'err': Bugs, bad data, files not found, ...
sub emit_warn  {emit_done @_, "WARN"};     # syslog 'warning'
sub emit_note  {emit_done @_, "NOTE"};     # syslog 'notice'
sub emit_info  {emit_done @_, "INFO"};     # syslog 'info'
sub emit_ok    {emit_done @_, "OK"};       # copacetic
sub emit_debug {emit_done @_, "DEBUG"};    # syslog: Really boring diagnostic output.
sub emit_notry {emit_done @_, "NOTRY"};    # Untried
sub emit_unk   {emit_done @_, "UNK"};      # Unknown
sub emit_yes   {emit_done @_, "YES"};      # Yes
sub emit_no    {emit_done @_, "NO"};       # No
sub emit_none  {emit_done {-silent => 1}, @_, "NONE"}
# *Special* closes level quietly (prints no wrapup severity)

#
# Return the bullet string for the given level
#
sub _bullet {
    my ($this, $level) = @_;
    my $bullet = q{};
    if (ref($this->{bullets}) eq 'ARRAY') {
        my $pmax = $#{$this->{bullets}};
        $bullet = $this->{bullets}->[$level > $pmax ? $pmax : $level];
    }

    # TODO: Allow bullets to be given as CSV:  "* ,+ ,- ,  " for example.
    elsif ($this->{bullets}) {
        $bullet = $this->{bullets};
    }
    else {
        return q{};
    }
    my $pad = q{ } x ($this->{bullet_width} - length($bullet));
    return $bullet . $pad;
}

#
# Clean option keys
#
sub _clean_opts {
    my %in  = @_;
    my %out = ();
    foreach my $k (keys %in) {
        my $v = $in{$k};
        delete $in{$k};
        $k =~ s{^\s*-?(\w+)\s*}{$1}sxm;
        $out{lc $k} = $v;
    }
    return %out;
}

#
# Add ANSI color to a string, if ANSI is enabled
### TODO:  use Term::ANSIColor, a standard module (verify what perl version introduced it, tho)
#
sub _colorize {
    my ($str, $sev) = @_;
    my $zon  = q{};
    my $zoff = q{};
    $zon = chr(27) . '[1;31;40m' if $sev =~ m{\bEMERG(ENCY)?}i;        #bold red on black
    $zon = chr(27) . '[1;35m'    if $sev =~ m{\bALERT\b}i;             #bold magenta
    $zon = chr(27) . '[1;31m'    if $sev =~ m{\bCRIT(ICAL)?\b}i;       #bold red
    $zon = chr(27) . '[1;31m'    if $sev =~ m{\bFAIL(URE)?\b}i;        #bold red
    $zon = chr(27) . '[1;31m'    if $sev =~ m{\bFATAL\b}i;             #bold red
    $zon = chr(27) . '[31m'      if $sev =~ m{\bERR(OR)?\b}i;          #red
    $zon = chr(27) . '[33m'      if $sev =~ m{\bWARN(ING)?\b}i;        #yellow
    $zon = chr(27) . '[36m'      if $sev =~ m{\bNOTE\b}i;              #cyan
    $zon = chr(27) . '[32m'      if $sev =~ m{\bINFO(RMATION)?\b}i;    #green
    $zon = chr(27) . '[1;32m'    if $sev =~ m{\bOK\b}i;                #bold green
    $zon = chr(27) . '[37;43m'   if $sev =~ m{\bDEBUG\b}i;             #grey on yellow
    $zon = chr(27) . '[30;47m'   if $sev =~ m{\bNOTRY\b}i;             #black on grey
    $zon = chr(27) . '[1;37;47m' if $sev =~ m{\bUNK(OWN)?\b}i;         #bold white on gray
    $zon = chr(27) . '[32m'      if $sev =~ m{\bYES\b}i;               #green
    $zon = chr(27) . '[31m'      if $sev =~ m{\bNO\b}i;                #red
    $zoff = chr(27) . '[0m' if $zon;
    return $zon . $str . $zoff;
}

#
# The level's envvar for this filehandle
#
sub _envvar {
    my $this = shift;
    return $this->{envbase} . _oid($this->{fh});
}

# Return an output identifier for the filehandle
#
sub _oid {
    my $fh = shift;
    return 'str' if ref($fh) eq 'SCALAR';
    return 0 if ref($fh);
    return fileno($fh || q{}) || 0;
}

#
# Figure out what was passed to us
#
#   Each $BASE_OBJECT in the hash is associated with one output ID (the oid).
#    The oid is just the fileno() of the file handle for normal output,
#    or the special text "str" when output is to a scalar string reference.
#    That's why we use a base object _hash_ instead of an array.
#   The $BASE_OBJECT{0} is the default one.  It's equivalent to whatever
#    oid was specified in the "use Term::Emit ... {-fh=>$blah}" which typically
#    is STDOUT (oid=1) but may be anything.
#
#   So what're we doing here?  We have to figure out which base object to use.
#   Our subs can be called four ways:
#       A) emit "blah";
#       B) emit *LOG, "blah";
#       C) $tobj->emit "blah";
#       D) $tobj->emit *LOG, "blah";
#   Also note that "emit {-fh=>*LOG},..." is considered equivalent to case B,
#   while "$tobj->emit {-fh=>*LOG},..." is considered equivalent to case D.
#
#   In case A, we simply use the default base object $BASE_OBJECT{0}.
#   In case B, we get the oid of *LOG and use that base object.
#       If the base object does not exist, then we make one,
#       cloning it from base object 0 but overriding with the file handle.
#   In case C, we use the base object $tobj - this is classic OO perl.
#   In case D, it's like case B except that if we have to make a new
#       base object, we clone from $tobj instead of base object 0.
#
sub _process_args {
    my $this = ref($_[0]) eq __PACKAGE__ ? shift : $BASE_OBJECT{0};
    my $oid = _oid($_[0]);
    if ($oid) {

        # We're given a filehandle or scalar ref for output.
        #   Find the associated base object or make a new one for it
        my $fh = shift;
        if ($fh eq $BASE_OBJECT{0}->{fh}) {

            # Use base object 0, 'cuz it matches
            $oid = 0;
        }
        elsif (!exists $BASE_OBJECT{$oid}) {
            $BASE_OBJECT{$oid} = $this->clone(-fh => $fh);
        }
        $this = $BASE_OBJECT{$oid};
    }
    my $opts = {};
    if (ref($_[0]) eq 'HASH') {
        $opts = {_clean_opts(%{shift()})};
    }
    return ($this, $opts, @_);
}

#
# Emit output to filehandle, string, whatever...
#
sub _spew {
    my $this = shift;
    my $out  = shift;
    my $fh   = $this->{fh};
    return ref($fh) eq 'SCALAR' ? ${$fh} .= $out : print {$fh} $out;
}

#
# Default timestamp
#
sub _timestamp {
    my $level = shift; #fwiw
    my ($s, $m, $h) = localtime(time());
    return sprintf "%2.2d:%2.2d:%2.2d ", $h, $m, $s;
}

#
# Wrap text to fit within line lengths
#   (Do we want to delete this and add a dependency to Text::Wrap ??)
#
sub _wrap {
    my ($msg, $min, $max) = @_;
    return ($msg)
        if !defined $msg
            || $max < 3
            || $min > $max;

    # First split on newlines
    my @lines = ();
    foreach my $line (split(/\n/, $msg)) {
        my $split = $line;

        # Then if each segment is more than the width, wrap it
        while (length($split) > $max) {

            # Look backwards for whitespace to split on
            my $pos = $max;
            while ($pos >= $min) {
                if (substr($split, $pos, 1) =~ m{\s}sxm) {
                    $pos++;
                    last;
                }
                $pos--;
            }
            $pos = $max if $pos < $min;    #no good place to break, use the max

            # Break it
            my $chunk = substr($split, 0, $pos);
            $chunk =~ s{\s+$}{}sxm;
            push @lines, $chunk;
            $split = substr($split, $pos, length($split) - $pos);
        }
        $split =~ s{\s+$}{}sxm;            #trim
        push @lines, $split;
    }
    return @lines;
}

### O ###

package Term::Emit::TiedClosure;

sub new {
    my ($proto, $base, @args) = @_;
    my $class = ref($proto) || $proto;     # Get the class name
    my $this = {-base => $base};
    bless($this, $class);
    $base->emit(@args);
    return $this;
}

sub DESTROY {
    my $this = shift;
    return $this->{-base}->emit_done();
}

1;                                         # EOM
__END__