File Coverage

blib/lib/Linux/IO_Prio.pm

Criterion	Covered	Total	%
statement	48	56	85.7
branch	5	12	41.6
condition	1	3	33.3
subroutine	17	19	89.4
pod	8	8	100.0
total	79	98	80.6

package Linux::IO_Prio;

use strict;
use warnings;

require Exporter;
use vars qw(@ISA @EXPORT_OK %EXPORT_TAGS $VERSION);
use POSIX qw(ENOSYS);
use Carp;

$VERSION     = '0.03';
@ISA         = qw(Exporter);
%EXPORT_TAGS = (ionice => [qw(&ionice &ionice_class &ionice_data)],
	        c_api => [qw(&ioprio_set &ioprio_get)],
		macros => [qw(IOPRIO_PRIO_VALUE IOPRIO_PRIO_CLASS IOPRIO_PRIO_DATA)],
		who => [qw(IOPRIO_WHO_PROCESS IOPRIO_WHO_PGRP IOPRIO_WHO_USE)],
		class => [qw(IOPRIO_CLASS_NONE IOPRIO_CLASS_RT IOPRIO_CLASS_BE IOPRIO_CLASS_IDLE)]
	       );
# The tag lists are exclusive at the moment, so don't worry about duplicates.
push @{$EXPORT_TAGS{all}}, @{$EXPORT_TAGS{$_}} foreach keys %EXPORT_TAGS;
Exporter::export_ok_tags($_) foreach keys %EXPORT_TAGS;

use constant IOPRIO_CLASS_SHIFT => 13;
use constant IOPRIO_PRIO_MASK => ((1 << IOPRIO_CLASS_SHIFT) - 1);
use constant {
    IOPRIO_WHO_PROCESS => 1,
    IOPRIO_WHO_PGRP => 2,
    IOPRIO_WHO_USER => 3
};
use constant {
    IOPRIO_CLASS_NONE => 0,
    IOPRIO_CLASS_RT => 1,
    IOPRIO_CLASS_BE => 2,
    IOPRIO_CLASS_IDLE => 3
};

if ($^O eq 'linux') {
    _load_syscall();
}
else {
    warn "Linux::IO_Prio: unsupported operating system -- $^O\n";
}

# Load syscall.ph
sub _load_syscall {
    return eval{require('syscall.ph') || require('sys/syscall.ph')};
}

# C API functions
# int ioprio_get(int which, int who);
sub ioprio_get {
    my ($which, $who) = @_;
    if (defined &SYS_ioprio_get) {
        return syscall(SYS_ioprio_get(), $which, $who);
    }
    else {
	return _not_implemented();
    }
}

# int ioprio_set(int which, int who, int ioprio);
sub ioprio_set {
    my ($which, $who, $ioprio) = @_;
    if (defined &SYS_ioprio_set) {
	return syscall(SYS_ioprio_set(), $which, $who, $ioprio);
    }
    else {
	return _not_implemented();
    }
}

# C API Macros
sub IOPRIO_PRIO_VALUE {
    my ($class, $data) =  @_;
    return ($class << IOPRIO_CLASS_SHIFT) | $data;
}

sub IOPRIO_PRIO_CLASS {
    my ($mask) = @_;
    return ($mask >> IOPRIO_CLASS_SHIFT);
}

sub IOPRIO_PRIO_DATA {
    my ($mask) = @_;
    return ($mask & IOPRIO_PRIO_MASK);
}

# Wrapper functions
sub ionice {
    my ($which, $who, $class, $data) = @_;
    carp "Data not permitted for class IOPRIO_CLASS_IDLE" if $class == IOPRIO_CLASS_IDLE && $data;
    return ioprio_set($which, $who, IOPRIO_PRIO_VALUE($class, $data));
}

sub ionice_class {
    my ($which, $who) = @_;
    if((my $priority = ioprio_get($which, $who)) < 0) {
	return $priority;
    }
    else {
	return IOPRIO_PRIO_CLASS($priority);
    }
}

sub ionice_data {
    my ($which, $who) = @_;
    if((my $priority = ioprio_get($which, $who)) < 0) {
	return $priority;
    }
    else {
	return IOPRIO_PRIO_DATA($priority);
    }
}

# Stub for not implemented
sub _not_implemented {
    $! = ENOSYS;
    return -1;
}

1;
__END__