File Coverage

blib/lib/Inferno/RegMgr/Utils.pm

Criterion	Covered	Total	%
statement	30	68	44.1
branch	0	26	0.0
condition	0	3	0.0
subroutine	10	15	66.6
pod	5	5	100.0
total	45	117	38.4

package Inferno::RegMgr::Utils;

use warnings;
use strict;
use Carp;

# update POD & Changes & README
use version; our $VERSION = qv('0.1.2');

# update DEPENDENCIES in POD & Makefile.PL & README
use Perl6::Export::Attrs;


sub quote :Export {
    my ($s) = @_;
    if ($s =~ / \s | ' | \A\z /xms) {
        $s =~ s/'/''/xmsg;
        $s = "'$s'";
    }
    return $s;
}

sub unquote :Export {
    my ($s) = @_;
    if ($s =~ s/\A'(.*)'\z/$1/xms) {
        $s =~ s/''/'/xmsg;
    }
    return $s;
}

sub attr :Export {
    my ($attr) = @_;
    my @s;
    while (my ($k, $v) = each %{ $attr || {} }) {
        push @s, sprintf '%s %s', quote($k), quote($v);
    }
    return join q{ }, @s;
}

my $qword = qr{( [^'\s]+ | '[^']*(?:''[^']*)*' )}xms;
sub parse_svc :Export {
    my ($s) = @_;
    return ({}, undef) if $s eq q{};
    return (undef, 'no \\n at end') if $s !~ /\n\z/xms;
    my %svc;
    for my $line (split /\n/xms, $s) {
        my $errmsg = "can't parse service: $line";
        return (undef, $errmsg) if $line !~ s/\A$qword//xms;
        my $name = unquote($1);
        my %attr;
        while (length $line) {
            return (undef, $errmsg) if $line !~ s/\s$qword\s$qword//xms;
            my ($attr, $value) = ($1, $2);
            $attr{ unquote($attr) } = unquote($value);
        }
        $svc{$name} = \%attr;
    }
    return (\%svc, undef);
}

my $STDREF = qr{SCALAR|ARRAY|HASH|CODE|REF|GLOB|LVALUE}xms;
sub run_callback :Export { ## no critic (RequireArgUnpacking)
    croak  'usage: run_callback( CB [, METHOD [, @ARGS]] )'    if @_ < 1;
    my ($cb, $method) = (shift, shift);
    my $cb_type
        = !ref($cb)                         ? 'CLASS'
        : ref($cb) eq 'CODE'                ? 'CODE'
        : ref($cb) !~ m{\A$STDREF\z}xmso    ? 'OBJECT'
        :                                     undef
        ;
    if ($cb_type eq 'CLASS' || $cb_type eq 'OBJECT') {
        $cb->$method(@_);
    }
    elsif ($cb_type eq 'CODE') {
        $cb->(@_);
    }
    else {
        croak qq{run_callback: wrong CB $cb};
    }
    return;
}



1; # Magic true value required at end of module
__END__