File Coverage

blib/lib/Net/IMP/Base.pm

Criterion	Covered	Total	%
statement	65	143	45.4
branch	17	60	28.3
condition	0	15	0.0
subroutine	13	20	65.0
pod	13	14	92.8
total	108	252	42.8

use strict;
use warnings;

package Net::IMP::Base;
use Net::IMP qw(:DEFAULT IMP_PASS_IF_BUSY);
use Carp 'croak';
use fields (
    'factory_args', # arguments given to new_factory
    'meta',         # hash with meta data given to new_analyzer
    'analyzer_cb',  # callback, set from new_analyzer or with set_callback
    'analyzer_rv',  # collected results for polling or callback, set
		    # from add_results
    'ignore_rv',    # hash with return values like IMP_PAUSE or
		    # IMP_REPLACE_LATER which are unsupported by the data
		    # provider and can be ignored
    'busy',         # if data provider is busy
);

use Net::IMP::Debug;


############################################################################
# API plugin methods
############################################################################

# creates new factory
sub new_factory {
    my ($class,%args) = @_;
    my Net::IMP::Base $factory = fields::new($class);
    $factory->{factory_args} = \%args;
    return $factory;
}

# make string from hash config, using URL encoding to escape special chars
sub cfg2str {
    my (undef,%cfg) = @_;
    return join('&', map {
	my $v = $cfg{$_};
	# only encode really necessary stuff
	s{([=&%\x00-\x20\x7f-\xff])}{ sprintf("%%%02X",ord($1)) }eg; # key
	if ( defined $v ) { # value
	    $v =~s{([&%\x00-\x20\x7f-\xff])}{ sprintf("%%%02X",ord($1)) }eg;
	    "$_=$v"
	} else {
	    "$_"
	}
    } sort keys %cfg);
}

# make has config from string created by cfg2str
sub str2cfg {
    my (undef,$str) = @_;
    my %cfg;
    for my $kv (split('&',$str)) {
	my ($k,$v) = $kv =~m{^([^=]+)(?:=(.*))?};
	$k =~s{%([\dA-F][\dA-F])}{ chr(hex($1)) }ieg;
	exists $cfg{$k} and croak "duplicate definition for key $k";
	$v =~s{%([\dA-F][\dA-F])}{ chr(hex($1)) }ieg if defined $v;
	$cfg{$k} = $v;
    }
    return %cfg;
}

# validate config, return list of errors
sub validate_cfg {
    my (undef,%cfg) = @_;
    delete $cfg{eventlib}; # accepted everywhere
    return %cfg ? "unexpected config keys ".join(', ',keys %cfg) : ();
}

############################################################################
# API factory methods
############################################################################

# create new analyzer
sub new_analyzer {
    my Net::IMP::Base $factory = shift;
    my %args = @_;
    my $cb = delete $args{cb};

    my $analyzer = fields::new(ref($factory));
    %$analyzer = (
	%$factory,          # common properties of all analyzers
	%args,              # properties of this analyzer
	analyzer_rv => [],  # reset queued return values
	busy => undef,      # busy per dir
    );
    $analyzer->set_callback(@$cb) if $cb;
    return $analyzer;
}

# get available interfaces
# returns factory for the given interface
# might be a new one or same as called on
sub set_interface {
    my Net::IMP::Base $factory = shift;
    my $want = shift;
    my ($if) = $factory->get_interface($want) or return;

    my %ignore = map { $_+0 => $_ }
	( IMP_PAUSE, IMP_CONTINUE, IMP_REPLACE_LATER );
    delete @ignore{ map { $_+0 } @{$if->[1]}};
    $factory->{ignore_rv} = %ignore ? \%ignore : undef;

    if ( my $adaptor = $if->[2] ) {
	# use adaptor
	return $adaptor->new_factory(factory => $factory)
    } else {
	return $factory
    }
}

# returns list of available [ if, adaptor_class ], restricted by given  @if
sub INTERFACE { die "needs to be implemented" }
sub get_interface {
    my Net::IMP::Base $factory = shift;
    my @local = $factory->INTERFACE;

    # return all supported interfaces if none are given
    return @local if ! @_;

    # find matching interfaces
    my @match;
    for my $if (@_) {
	my ($in,$out) = @$if;
	for my $lif (@local) {
	    my ($lin,$lout,$adaptor) = @$lif;
	    if ( $lin and $lin != $in ) {
		# no match data type/proto
		debug("data type mismatch: want $in have $lin");
		next;
	    }

	    if ( ! $out || ! @$out ) {
		# caller will accept any return types
	    } else {
		# any local return types from not in out?
		my %lout = map { $_ => 1 } ( @$lout, IMP_FATAL );
		delete @lout{
		    @$out,
		    # these don't need to be supported
		    (IMP_PAUSE, IMP_CONTINUE, IMP_REPLACE_LATER)
		};
		if ( %lout ) {
		    # caller does not support all return types
		    debug("no support for return types ".join(' ',keys %lout));
		    next;
		}
	    }

	    if ( $adaptor ) {
		# make sure adaptor class exists
		if ( ! eval "require $adaptor" ) {
		    debug("failed to load $adaptor: $@");
		    next;
		}
	    }

	    # matches
	    push @match, [ $in,$out,$adaptor ];
	    last;
	}
    }

    return @match;
}

############################################################################
# API analyzer methods
############################################################################

# set callback
sub set_callback {
    my Net::IMP::Base $analyzer = shift;
    my ($sub,@args) = @_;
    $analyzer->{analyzer_cb} = $sub ? [ $sub,@args ]:undef;
    $analyzer->run_callback if $analyzer->{analyzer_rv};
}

# return queued results
sub poll_results {
    my Net::IMP::Base $analyzer = shift;
    my $rv = $analyzer->{analyzer_rv};
    $analyzer->{analyzer_rv} = [];
    return @$rv;
}

sub data { die "needs to be implemented" }

sub busy {
    my Net::IMP::Base $analyzer = shift;
    my ($dir,$busy) = @_;
    if ( $busy ) {
	return if $analyzer->{busy}
	    && $analyzer->{busy}[$dir]; # no change - stay busy
	$analyzer->{busy}[$dir] = 1; # unbusy -> busy
    } elsif ( ! $analyzer->{busy}
	|| ! $analyzer->{busy}[$dir] ) {
	return; # no change - stay not busy
    } else {
	# set to no busy on $dir, maybe no busy at all
	$analyzer->{busy}[$dir] = 0;  # busy -> unbusy
	if ( ! grep { $_ } @{$analyzer->{busy}} ) {
	    # all dir are not busy anymore
	    $analyzer->{busy} = undef;
	}
    }

    # run callback, either for important stuff on busy or for
    # all stuff if not busy
    $analyzer->run_callback;
}


############################################################################
# internal analyzer methods
############################################################################

sub add_results {
    my Net::IMP::Base $analyzer = shift;
    if ( my $ignore = $analyzer->{ignore_rv} ) {
	push @{$analyzer->{analyzer_rv}}, grep { ! $ignore->{$_->[0]+0} } @_;
    } else {
	push @{$analyzer->{analyzer_rv}},@_;
    }
}

{
    my %important = do {
	my $p = IMP_PASS_IF_BUSY;
	map { $p->[$_]+0 => $_+1 } (0..$#$p)
    };

    sub run_callback {
	my Net::IMP::Base $analyzer = shift;
	my $rv = $analyzer->{analyzer_rv}; # get collected results
	if (@_) {
	    # add more results
	    if ( my $ignore = $analyzer->{ignore_rv} ) {
		push @$rv, grep { ! $ignore->{$_->[0]+0} } @_;
	    } else {
		push @$rv,@_;
	    }
	}
	if ( my $cb = $analyzer->{analyzer_cb} ) {
	    my ($sub,@args) = @$cb;
	    if ( my $busy = $analyzer->{busy} ) {
		# at least one dir is busy
		my (@important,@nobusy,@busy);
		for( @$rv ) {
		    if ( my $lvl = $important{ $_->[0]+0 } ) {
			push @important,[ $_, $lvl ]
		    } elsif ( $busy->[$_->[1]] ) {
			push @busy,$_
		    } else {
			push @nobusy,$_
		    }
		}
		# sort by importance
		@important =
		    map { $_->[0] } sort { $a->[1] <=> $b->[1] } @important
		    if @important;
		if (@nobusy || @important) {
		    $analyzer->{analyzer_rv} = \@busy;
		    $sub->(@args,@important,@nobusy);
		} else {
		    # nothing important enough to call back
		}
	    } elsif (@$rv) {
		$analyzer->{analyzer_rv} = []; # reset
		$sub->(@args,@$rv); # and call back
	    }
	}
    }
}


1;
__END__