File Coverage

blib/lib/Logwatch/RecordTree.pm

Criterion	Covered	Total	%
statement	153	247	61.9
branch	39	90	43.3
condition	17	30	56.6
subroutine	26	32	81.2
pod	12	16	75.0
total	247	415	59.5

#!/usr/bin/perl
#===============================================================================
#      PODNAME:  Logwatch::RecordTree
#     ABSTRACT:  an object to collect and print Logwatch events
#
#       AUTHOR:  Reid Augustin (REID)
#        EMAIL:  [e-mail]
#      CREATED:  Thu Mar 12 18:41:04 PDT 2015
#===============================================================================

use 5.008;
use strict;
use warnings;

package Logwatch::RecordTree;
use Moo;
use Carp qw( croak );
use UNIVERSAL::require;
use List::Util qw ( max min sum );
use Sort::Key::Natural qw( natsort natkeysort );

our $VERSION = '2.055'; # VERSION

use overload '""' => \&sprint;

my $_defaults = {};   # class variable

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

    my $name = ref $self || $self;
    $_defaults->{$name} ||= {};  # a hash for each sub-class
    return $_defaults->{$name};
}

sub import {
    my ($class, %hash) = @_;

    my $defaults = $class->defaults();
    while (my ($key, $value) = each %hash) {
        $defaults->{$key} = $value;
    }
}

sub check_coderef { die 'Not a CODE ref' if (ref $_[0] ne 'CODE') };
sub check_hashref { die 'Not a HASH ref' if (ref $_[0] ne 'HASH') };
sub check_arryref { die 'Not an ARRAY ref' if (ref $_[0] ne 'ARRAY') };

has name => (           # name/title for this item
    is => 'ro',
);
has sprint_name => (    # callback to print the name
    is => 'rw',
    isa => \&check_coderef,
    default => sub {
        sub {
            return $_[0]->name;
        }
    },
);
has sort_key => (       # this overrides ->name in sort_children
    is => 'rw',
);
has case_sensitive => (
    is => 'rw',
);
has count => (          # count how many times we log this event
    is => 'rw',
    default => sub { 0 },
    trigger => sub {
        $_[0]->no_count;
    }
);
has count_fields => (       # fields to make the count
    is => 'rw',
    isa => \&check_arryref,
    default => sub { [] },
);
has count_formatted => ( # count and extended fields, after formatting
    is => 'rw',
);
has no_count => (       # suppress count field (probably because it's the same as the parent)
    is => 'rw',
);
has children => (   # a hash of child Logwtch::RecordTrees
    is => 'rw',
    isa => \&check_hashref,
    default => sub { {} },
);
has limit => (      # limit number of children printed
    is => 'rw',
    default => sub { 0 },   # default to no limit
);
has indent => (     # how much to indent this level of the tree
    is => 'rw',
);
has no_indent => (  # flag to suppress indentation of children
    is => 'rw',
);
has curr_indent => (    # total indentation of this level
    is => 'rw',
    default => sub { '' },
);
has post_callback => (  # when array is ready for printing, call this for final adjustments
    is => 'rw',
    isa => \&check_coderef,
    default => sub { sub {} },
);
has lines => (  # when array is ready for printing, store a ref to it here
    is => 'rw',
    isa => \&check_arryref,
);
has columnize => (  # flag to indicate we should columnize children
    is => 'rw',
);
has neat_names => ( # for the neat freaks
    is => 'rw',
);
has neat_format => ( # formatter for neatness, set by sprint
    is => 'rw',
    default => sub { "%s" },    # not neat
);
has extra => (      # a little something extra...
    is => 'rw',
);

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

    while (my ($key, $value) = each %{$self->defaults}) {
        $self->$key($value);
    }
}

sub child_by_name { # find child by name(s), follow down the tree
    my ($self, @names) = @_;

    my $child = $self;
    for my $name (@names) {
        return if (not exists $child->children->{$name});
        $child = $child->children->{$name};
    }
    return $child;
}

sub create_child { # create child, add to children
    my ($self, $name, $type, $opts) = @_;

    $type ||= __PACKAGE__;  # default to this package
    $opts ||= {};
    $opts->{name} = $name;
    $type->require or croak($@);
    return $self->children->{$name} = $type->new( %{$opts} );
}

# adopt items, handle name conflicts
sub adopt {
    my ($self, $item) = @_;

    my $item_name = $item->name;
    my $my_child = $self->child_by_name($item_name);
    if ($my_child) {
        # name conflict.  my_child must adopt $item's children
        my @item_children = values %{$item->children};
        if (@item_children) {
            for my $child (@item_children) {
                $my_child->adopt($child);
            }
        }
        else {
            # no children, so transfer count directly from item to my_child
            $my_child->count($my_child->count + $item->count);
        }
    }
    else {
        # no name conflict, just copy over
        $self->children->{$item_name} = $item;
    }
    $self->count($self->count + $item->count);
}

# log event, add new children if necessaary
sub _log_children {
    my ($self, $name, @children) = @_;

    my ($type, $opts);
    if (ref $name eq 'ARRAY') {
        ($name, $type, $opts) = @{$name};
    }

    $name = "" if (not defined $name);  # supposed to be a list of names or array-refs

    my $child = $self->child_by_name($name);
    if (not defined $child) {
        $child = $self->create_child($name, $type, $opts)
    }

    if (@children) {
        return $child->_log_children(@children);
    }

    return $child;
}

sub _count { # add 1 to count down the path
    my ($self, $name, @children) = @_;

    $self->count($self->count + 1);

    $name = $name->[0] if (ref $name);
    if (defined $name) {
        return $self->child_by_name($name)->_count(@children);
    }
    return $self;
}

sub log_no_count { # log new event without counting, add children if necessary
    my ($self, @args) = @_;

    return $self->_log_children(@args);
}

sub log { # log new event adding to count, add children if necessary
    my ($self, @args) = @_;

    $self->_log_children(@args);
    return $self->_count(@args);
}

# return sorted list of child names
sub sort_children { # sort children
    my ($self) = @_;

    # make hash, value is name, key is sort_key or name
    my %keys = map { (defined($_->sort_key) ? $_->sort_key : $_->name) => $_ }
                   values %{$self->children};

    # sort by hash keys, create array of values to get back to names
    my @children = $self->case_sensitive
      ? map { $keys{$_} } natsort  keys %keys
      : map { $keys{$_} } natkeysort { lc $_ } keys %keys;

    return wantarray
        ?  @children
        : \@children;
}

# make neat column of child names
sub _neaten_children {
    my ($self) = @_;

    my $max = max(1, map { length $_->sprint_name->($_) } values %{$self->children});
    my $format = $self->neat_names < 0
      ? "%-${max}s"
      : "%${max}s";
    map { $_->neat_format($format) } values %{$self->children};
}

# make neat columns of all the count fields
sub _format_child_counts {
    my ($self, $children, $depth) = @_;

    # measure each field, save max length for each column
    my @maxes;
    for my $child (values %{$children}) {
        unshift @{$child->count_fields}, $child->count;
        my $ii = 0;
        for my $field (@{$child->count_fields}) {
            $maxes[$ii] = max($maxes[$ii] || 0, length $field);
            $ii++;
        }
    }

    # string to indent children: total count field width or at least 3
    my $min = sum(1, @maxes);
    $min = 3 if ($min < 3);
    my $child_indent = " " x $min;

    # pad all fields to the max for the column
    for my $child (values %{$children}) {
        my $ccf = $child->count_fields;
        my @padded;
        for my $ii (0 .. $#maxes) {
            $padded[$ii] = sprintf "%*s", $maxes[$ii], $ccf->[$ii] || '';
        }
        $child->count_formatted(join '', @padded);
        $child->indent($child_indent) if (not defined $child->indent);
        shift @{$child->count_fields};  # remove the count field we inserted above
    }
}

# compare our count fields to $other's (for suppression when identical)
sub _count_fields_differ {
    my ($self, $other) = @_;

    return 1 if ($self->count != $other->count);
    for my $ii (0 .. max($#{$self->count_fields}, $#{$other->count_fields})) {
        return 1 if (
            not defined $self->count_fields->[$ii] or
            not defined $other->count_fields->[$ii] or
            $self->count_fields->[$ii] ne $other->count_fields->[$ii]);
    }
    return 0;   # match
}

sub sprint {
    my ($self, $callback, $path, $parent_indent, $depth) = @_;

    $path          ||= [];
    $parent_indent ||= '';
    $depth         ||= 1;

    if ($depth == 1) {
        # top level needs to format its own count field
        $self->_format_child_counts({ top => $self }, 0);
    }

    my $count = $self->no_count
      ? ''
      : $self->count_formatted . ' ';

    $self->lines(my $lines = []);

    if (length($self->name)) {
        push @{$lines}, join( '',
            $count,
            sprintf $self->neat_format, $self->sprint_name->($self),
        );
    }
    else {
        push @{$lines}, ''; # name is blank, so don't add anything here
    }

    # format count fields and calculate indent for all children,
    $self->_format_child_counts($self->children, $depth);

    my $children    = $self->sort_children;
    my $child_count = @{$children};

    if ($child_count == 1) {    # join single child to this line
        my $child = $children->[0];
        # save the child's flags we're going to alter
        my %flags = map { $_ => $child->$_ } qw( no_count no_indent );
        # suppress count field if child's is same as ours
        $child->no_count(1) if (not $self->_count_fields_differ($child));
        $child->no_indent(1);
        $child->curr_indent($parent_indent);    # no extra indent since we concat this line

        push @{$path}, $child->name;
        $child->sprint($callback, $path, $self->curr_indent, $depth + 1);
        if (length($lines->[0]) + length($child->lines->[0]) <= $self->width) {
            $lines->[0] .= ' ' . shift @{$child->lines};
        }
        push @{$lines}, @{$child->lines};
        pop @{$path};

        # restore child's flags
        map { $child->$_($flags{$_}) } keys %flags;
    }

    if ($child_count > 1) {
        my $last = $self->limit || $child_count; # if limit is zero, print all
        $last = $child_count if ($child_count - $last < 3); # if within 3, just print all
        $last = $child_count - $last;     # convert from limit to the last index

        # handle neat_children flag
        $self->_neaten_children if ($self->neat_names);

        for my $child (@{$children}) {
            $child->curr_indent($parent_indent . $self->indent);
            if ($child_count <= $last) {
                push @{$lines}, "... and $child_count more";
                last;
            }
            push @{$path}, $child->name;
            $child->sprint($callback, $path, $self->curr_indent, $depth + 1);
            push @{$lines}, @{$child->lines};
            pop  @{$path};
            $child_count--;
        }
    }

    $self->sprint_columns if ($self->columnize);

    # indent children
    if (not $self->no_indent) {
        for my $ii (1 .. $#{$lines}) {
            $lines->[$ii] = $self->indent . $lines->[$ii];
        }
    }

    $self->post_callback->($self, $path);

    $callback->($self, $path) if ($callback);

    return join "\n", @{$lines};
}

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

    if (@_ > 1) {
        $self->{_width} = $new;
    }
    return $self->{_width} if (exists $self->{_width});
    return 80;  # default page width
}

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

    if (@_ > 1) {
        $self->{_col_width} = $new;
    }

    if (not exists $self->{_col_width}) {
        # find longest line length, excluding the first line
        my $lines = $self->lines;
        $self->{_col_width} = max( 1, map { length $lines->[$_] } (1 .. $#{$lines}));
    }
    return $self->{_col_width};
}

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

    if (@_ > 1) {
        $self->{_col_count} = $new;
    }

    if (not exists $self->{_col_count}) {
        # calculate from curr_indent, width, and col_width
        my $width = $self->width - length($self->curr_indent);
        $width = max(0, $width);    # at least 0
        $self->{_col_count} = int ($width / $self->col_width) || 1; # at least 1
    }
    return $self->{_col_count};
}

# re-arrange children into columns
sub sprint_columns {
    my ($self, $width, $col_count, $col_width) = @_;

    # allow caller to override width, col_count, and col_width
    $self->width($width)         if (defined $width);
    $self->col_count($col_count) if (defined $col_count);
    $self->col_width($col_width) if (defined $col_width);

    $col_count = $self->col_count;
    $col_width = $self->col_width;

    my $lines = $self->lines;
    my @new_lines = shift @{$lines};    # first line is unchanged

    my $lines_per_col = int ((@{$lines} + $col_count - 1) / $col_count);

    for my $ii (0 .. $lines_per_col - 1) {
        my @line;
        if ($col_count <= 1) {
            # single column, just prepend indent
            push @new_lines, join '',
                $self->indent,
                $lines->[$ii];
        }
        else {
            # join segments into a line of columns
            for my $jj (0 .. $col_count - 1) {
                my $l = $lines->[$ii + $jj * $lines_per_col];
                push @line, sprintf "%-*s", $col_width, $l if (defined $l);
            }
            push @new_lines, join '',
                $self->indent,
                join(' ', @line);
        }
    }
    $self->lines(\@new_lines);
}

1;

__END__