#!perl -w ## Author: Alois Mahdal at vornet 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 . 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; #TODO: Make them global my $DIV_FIELD =";"; my $DIV_VALUE ="="; # split to fields my @fields = split $DIV_FIELD, $message; %$data = map { my @fld = split $DIV_VALUE, $_; ( 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;