File Coverage

blib/lib/M3/ServerView/View.pm

Criterion	Covered	Total	%
statement	118	122	96.7
branch	39	42	92.8
condition	10	12	83.3
subroutine	22	24	91.6
pod	6	6	100.0
total	195	206	94.6

package M3::ServerView::View;

use strict;
use warnings;

use Carp qw(croak);
use POSIX qw(strftime);
use Scalar::Util qw(refaddr looks_like_number);

use M3::ServerView::Parser;
use M3::ServerView::ResultSet;

my %Entries;
my %Connection;
my %Response_time;
my %Request_time;
my %Url;

# Constructor
sub new {
    my ($pkg, $connection, $url) = @_;

    my $self = bless \do { my $v; }, $pkg;

    $Url{refaddr $self} = $url;
    $Connection{refaddr $self} = $connection if $connection;

    $self->reload();

    return $self;
}

# Deconstructor
sub DESTROY {
    my ($self) = @_;
    delete $Connection{refaddr $self};
    delete $Entries{refaddr $self};
    delete $Response_time{refaddr $self};
    delete $Request_time{refaddr $self};
    delete $Url{refaddr $self};
}

sub connection {
    my ($self) = @_;
    return $Connection{refaddr $self};
}

# Page loading
sub reload {
    my ($self) = @_;
    $self->_load();
}

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

    # Clear entries
    $Entries{refaddr $self} = [];

    return unless $Url{refaddr $self};

    # Fetch page
    $Request_time{refaddr $self} = CORE::time;
    my ($content, $response_time) = $self->connection->_get_page_contents($Url{refaddr $self});
    $Response_time{refaddr $self} = sprintf("%.6f", $response_time);

    # Parser contents
    $self->_parse($content);

    1;
}

# Generic fallback parser that uses M3::ServerView::Parser;
sub _entry_class {
    my ($self) = @_;
    croak "View class '", ref $self, "' doesn't override _entry_class()";
}

sub _entry_columns {
    my ($self) = @_;
    croak "View class '", ref $self, "' doesn't override _entry_columns()";
}

sub _parse {
    my ($self, $content) = @_;
    my $parser = M3::ServerView::Parser->new($self);
    $parser->parse($content);
}


sub _entries {
    my ($self) = @_;
    return $Entries{refaddr $self};
}

sub _add_entry {
    my ($self, $entry) = @_;
    push @{$Entries{refaddr $self}}, $entry;
}

sub response_time {
    my ($self) = @_;
    return $Response_time{refaddr $self};
}

sub request_time {
    my ($self, $format) = @_;
    my $time = $Request_time{refaddr $self};

    if ($format && $format eq "timestamp") {
        return $time;
    }

    return strftime("%Y-%m-%d %H:%M:%S", localtime($time));
}

sub search {
    my ($self, $query, $options) = @_;

    $options = {} unless ref $options eq "HASH";

    my @matches;

    # Build rules
    my $case_sensitive = $options->{case_sensitive};
    $case_sensitive = 0 unless defined $case_sensitive;
    my @matchers = _build_matchers($query, $case_sensitive);

    CHECK_ENTRIES: for my $entry (@{$self->_entries}) {
        # Check if entry matches all matchers and
        # break at the first that doens't
        !($_->($entry)) && next CHECK_ENTRIES for @matchers;

        push @matches, $entry;
    }

    # Sort results
    if (exists $options->{order_by}) {
        no warnings;
        my $key = $options->{order_by};
        my $sort_as = $options->{sort_as} || "";
        my $sort_order = lc($options->{sort_order}) || "asc";
        croak q{Sort order must be either 'asc' or 'desc'} unless $sort_order =~ /^asc|desc$/;
        if ($sort_order eq "asc") {
            if ($sort_as eq "text") {
                @matches = sort { $a->{$key} cmp $b->{$key} } @matches;
            }
            else {
                @matches = sort { $a->{$key} <=> $b->{$key} } @matches;
            }
        }
        else {
            if ($sort_as eq "text") {
                @matches = sort { $b->{$key} cmp $a->{$key} } @matches;
            }
            else {
                @matches = sort { $b->{$key} <=> $a->{$key} } @matches;
            }
        }
    }

    my $rs = M3::ServerView::ResultSet->new(\@matches);
    return $rs;
}

my %Op = (
    "=="    => sub { $_[0] == $_[1]; },
    "!="    => sub { $_[0] != $_[1]; },
    "<"     => sub { $_[0] < $_[1]; },
    ">"     => sub { $_[0] > $_[1]; },
    "<="    => sub { $_[0] <= $_[1]; },
    ">="    => sub { $_[0] >= $_[1]; },

    "eq"    => sub { $_[0] eq $_[1]; },
    "ne"    => sub { $_[0] ne $_[1]; },
    "lt"    => sub { $_[0] lt $_[1]; },
    "gt"    => sub { $_[0] gt $_[1]; },
    "le"    => sub { $_[0] le $_[1]; },
    "ge"    => sub { $_[0] ge $_[1]; },

    "like"  => sub { $_[0] =~ m{ $_[1] }xi; },
);

my %Op_transform = (
    "=="    => "eq",
    "!="    => "ne",
    ">"     => "gt",
    "<"     => "lt",
    ">="    => "ge",
    "<="    => "le",
);

sub _build_matchers {
    my ($rules, $case_sensitive) = @_;

    $rules = {} unless $rules;

    my @matchers;

    while (my ($key, $rule) = each %$rules) {
        my ($op, $value) = ("==", $rule);

        if (ref $rule eq "ARRAY") {
            ($op, $value) = @$rule;
        }

        croak "Don't know how to handle op '${op}'" if !exists $Op{$op};

        if (!looks_like_number($value) && exists $Op_transform{$op}) {
            $op = $Op_transform{$op};
        }

        my $matcher;

        # Basicly the same subroutine except we lowercase the contents if we
        # perform a case-insensitive match
        if ($case_sensitive) {
            $matcher = sub {
                my $entry = shift;
                return 0 unless exists $entry->{$key};
                return 0 unless defined $entry->{$key};
                return 0 unless $Op{$op}->($entry->{$key}, $value);
                return 1;
            };
        }
        else {
            $matcher = sub {
                my $entry = shift;
                return 0 unless exists $entry->{$key};
                return 0 unless defined $entry->{$key};
                return 0 unless $Op{$op}->(lc($entry->{$key}), lc($value));
                return 1;
            };
        }

        push @matchers, $matcher;
    }

    return @matchers;
}

1;
__END__