File Coverage

lib/Told/Client.pm

Criterion	Covered	Total	%
statement	112	129	86.8
branch	45	72	62.5
condition	14	20	70.0
subroutine	14	15	93.3
pod	0	10	0.0
total	185	246	75.2

package Told::Client;

use 5.016002;
use strict;
use warnings;

use JSON;
use LWP;

require Exporter;

our @ISA = qw(Exporter);

our %EXPORT_TAGS = ( 'all' => [ qw(
	tell
    setDebug
    setConnectionType
    setHost
    setType
    setTags
    setDefaulttags
) ] );

our @EXPORT_OK = ( @{ $EXPORT_TAGS{'all'} } );

our @EXPORT = qw(
    getParams
);

our $VERSION = '0.01';

sub new {
    my $package = shift;
    my $config = shift;
    my $recref = {};
    bless $recref, $package;
    $recref->setHost(           $config->{'host'} || '');
    $recref->setType(           $config->{'type'} || '');
    $recref->setDefaulttags(    @{$config->{'defaulttags'}}) if($config->{'defaulttags'});
    $recref->setTags(           @{$config->{'tags'}}) if($config->{'tags'});
    $recref->setConnectionType( $config->{'connection'} || 'POST');

    return $recref;
}

sub setDebug {
    my $self = shift;
    if(@_) {
        $self->{'verbose'} = shift;
    }
    print "Told::Client in debug mode.\n" if $self->{'verbose'};
}

sub getParams {
    my $self = shift;
    my $param = {
        'host' => $self->{'host'}
        , 'type' => $self->{'type'}
        , 'defaulttags' => $self->{'defaulttags'}
        , 'tags' => $self->{'tags'}
    };
    return $param;
}


sub setConnectionType {
    my $self = shift;
    my $type = shift;
    if($type) {
        if($type =~ /GET|POST|UDP/i){
            $self->{'connectiontype'} = $type;
        } else {
            warn("Connectiontype ".$type." is not known.") if $self->{'verbose'};
            return 0;
        }
    }
    return 1;
}


sub setHost {
    my $self = shift;
    if(@_) {
        $self->{'host'} = shift;
    }
    print "Setting host to: ". $self->{'host'} ."\n" if $self->{'verbose'};
}

sub setType {
    my $self = shift;
    if(@_) {
        $self->{'type'} = shift;
    }
    print "Setting type to: ". $self->{'type'} ."\n" if $self->{'verbose'};
}

sub setTags {
    my $self = shift;
    my @tags;
    while(@_){
        push(@tags, shift);
    }
    $self->{'tags'} = \@tags;
    print "Setting tags to: ". join(", ", @{$self->{'tags'}}) ."\n" if $self->{'verbose'};
}

sub setDefaulttags {
    my $self = shift;
    my @defaulttags;
    while(@_){
        push(@defaulttags, shift);
    }
    $self->{'defaulttags'} = \@defaulttags;
    print "Setting defaulttags to: ". join(", ", @{$self->{'defaulttags'}}) ."\n" if $self->{'verbose'};
}

sub tell {
    my $self = shift;
    my ($_message, $_type, @_tags) = @_;

    my $browser = LWP::UserAgent->new;
    if(!$self->{'host'} || length($self->{'host'}) == 0){
        warn "No host ist set\n" if $self->{'verbose'};
        return 0;
    }
    $self->{'host'} =~ s/^(([a-z]{0,5}\:\/\/)?([^\/]+))\/?$/$1/isg;

    my @tags = ();
    my $cnt_fn_tags = @_tags;
    my $cnt_known_tags = @{$self->{'tags'}} if($self->{'tags'});
    @tags = @{$self->{'defaulttags'}} if($self->{'defaulttags'} && ($cnt_fn_tags <= 0 && $cnt_known_tags <= 0));

    foreach my $t(@{$self->{'tags'}} ){
        push(@tags, $t);
    }
    if($cnt_fn_tags > 0){
    	foreach my $t(@_tags){
    		push(@tags, $t);
    	}

    }

	my $type = $_type || $self->{'type'} || "";
 	my $message;
	if (ref($_message) eq "HASH") {

        if($_message->{type}){
            $type = $_message->{type} if($type eq '');
            delete $_message->{type};
        }
        if($_message->{tags}){
			foreach my $t(@{$_message->{tags}}){
                push(@tags, $t);
            };
            delete $_message->{tags};
        }
        # if there is only one message as string:
        if( ref($_message->{message}) eq ''  ){
        	$message = $_message->{message};
        } else {
        	$message = $_message;
        	if($self->{'connectiontype'} eq 'GET'){
        		warn("This message can not be send via get. Set the Type to POST automaticly for this message.") if $self->{'verbose'};
        		$self->{'connectiontype'} = 'POST';
        	}
        }
    }

    my $result;
    if($self->{'connectiontype'} eq 'GET'){
	    my $query;
	    $query .= "message=". $message if($message);
	    my $anz_tags = @tags;
	    if($anz_tags > 0){
	    	$query .= "&" if($message && length($message) > 0);
	        $query .= 'tags=';
    	    $query .= join(",", uniq(@tags));
    	    $query .= "&" if(length($type) > 0)
    	}
        $query .= "etype=". $type if(length($type) > 0);

        if($self->{'host'} =~ /^test/){
            $result = $self->{'host'}."/log?". $query;
        } else {
            $result = $browser->get($self->{'host'}."/log?". $query);
        }
    }
    elsif($self->{'connectiontype'} eq 'POST'){
    	my %data;
    	$data{'etype'} = $type;
    	$data{'tags'} = \@tags;
    	$data{'message'} = $message;

    	if($self->{'host'} =~ /^test/){
            $result = encode_json(\%data);
    	} else {
        	$result = $browser->post($self->{'host'}."/log"
           		, encode_json \%data
	        );
	    }
    } elsif($self->{'connectiontype'} eq 'UDP'){
    	die("UDP is not supported, yet");
    } else {
    	warn("Connection type ". $self->{'connectiontype'}
    		." is not supportet.\nSet the Type to POST automaticly for this message.")
    		if $self->{'verbose'};
    	$self->setConnectionType("POST");
    	$result = $self->tell($_message, $_type, @_tags);
    }
    return $result;
}

### PRIVATES ###

sub uniq {
    return keys %{{ map { $_ => 1 } @_ }};
}

1;
__END__