minions/lib/htsheet.pm

#!perl -w

## Author: Alois Mahdal at zxcvb cz
# Helper class to help parse logs from a very primitive remote logging
# service.  Used by minions/bin/mksheet.pl to parse logs from htlog.cgi

# This program is free software: you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation, either version 3 of the License, or
# (at your option) any later version.

# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU General Public License for more details.

# You should have received a copy of the GNU General Public License
# along with this program.  If not, see <http://www.gnu.org/licenses/>.


package htsheet;
use strict;
use warnings;
use Carp;


##############
# load logfile
sub load {
    my ($class, $args) = @_;

    # make yourself
    my $self = {};
    $self->{data}->{main_columns}   = [ qw/Time Origin Tag I/ ];
    $self->{parsed}                 = 0;
    $self->{lines}                  = [];
    $self->{file}                   = $args->{file}
        or croak("missing mandatory option: file");

    # slurp the file
    open my $fh, "<", $self->{file}
        or croak("could not open file: $!");
    @{$self->{lines}} = <$fh>;
    chomp @{$self->{lines}};
    close $fh or croak("could not close file: $!");
    carp("zero lines loaded") unless @{$self->{lines}};

    # bless and go
    bless $self, $class;
    return $self;
}


###############################################
# parse out common fields and message from line
sub parse_line {
    my ($self, $line) = @_;
    my $row;
    my $row_head;
    my $row_data;

    ($row_head->{Time})     = $line
        =~ m|Time: (\d\d\d\d-\d\d-\d\d \d\d:\d\d:\d\d);|;
    ($row_head->{Origin})   = $line =~ m|Origin: (\S*);|;
    ($row_head->{Tag})      = $line =~ m|Tag: (.*?);|;
    ($row_head->{I})        = $line =~ m|I: (.*?);|;
    ($row_head->{Message})  = $line =~ m|Message: (.*)$|;

    # parse oout Message: and throw it away
    $row_data = $self->parse_message($row_head->{Message});
    delete $row_head->{Message};

    # merge head and data
    %$row = (%$row_head, %$row_data);
    return $row;
}


################################
# parse data part of the message
sub parse_message {
    my ($self, $message) = @_;
    my $data;

    # split to fields
    my @fields  = split ";", $message;
    %$data      = map {
        my @fld = split "=", $_;
        ( 2 == scalar @fld ? @fld : (dummy => 'non-parseable') )
    } @fields;

    # merge field ames with those already found
    $self->{data}->{data_columns}->{$_}++ foreach (keys %$data);

    return $data;
}


#################
# parse all lines
sub parse_all {
    my ($self) = @_;
    foreach (@{$self->{lines}}) {
        push @{$self->{data}->{rows}}, $self->parse_line($_);
    }
    return $self->{parsed} = 1;
}


###########################################
# render (non-tabular) rows into CSV string
sub to_csv {
    my $self = shift;
    my $output;

    # parse if it hasn't already been
    $self->{parsed} or $self->parse_all;

    # create list of columns
    my @columns = (
        @{$self->{data}->{main_columns}},
        sort keys %{$self->{data}->{data_columns}},
    );

    $output .= $self->array_to_csv(@columns);

    foreach my $row (@{$self->{data}->{rows}}) {
        my @line;
        foreach (@columns) {
            push @line, (defined $row->{$_} ? $row->{$_} : "" );
        }
        $output .= $self->array_to_csv(@line);
    }
    return $output;
}


################
# CSV line maker
sub array_to_csv {
    my $self = shift;
    my @out;
    foreach (@_) {
        push @out, "\"$_\"";
    };
    return join(";" , @out) . "\n";
}


######################################
# get list of unique values for column
sub get_unique_values_of {
    my ($self, $column) = @_;

    # parse if it hasn't already been
    $self->{parsed} or $self->parse_all;

    # count how many times which value is seen
    my %values;
    $values{$_->{$column}}++
        foreach @{ $self->{data}->{rows} };
   
    return [ keys %values ];
}


##################################################
# create your clone only with lines matching regex
sub grep {
    my ($self, $query) = @_;
    my $copy;

    $copy->{data}->{main_columns}   = [ @{$self->{data}->{main_columns}} ];
    $copy->{lines}                  = [ grep {m|$query|} @{$self->{lines}} ];
    carp "grep returned zero lines" unless @{$copy->{lines}};

    bless $copy, ref $self;
    return $copy;
}

1;