File Coverage

blib/lib/Linux/Proc/Mountinfo.pm

Criterion	Covered	Total	%
statement	51	87	58.6
branch	15	24	62.5
condition	5	10	50.0
subroutine	7	25	28.0
pod	3	3	100.0
total	81	149	54.3

package Linux::Proc::Mountinfo;

our $VERSION = '0.02';

use strict;
use warnings;
use Carp;

sub _key {
    my $mnt = shift;
    $mnt =~ s|/+|/|g;
    $mnt =~ s|/?$|/|;
    $mnt =~ s|([\0/])|\0$1|g;
    $mnt;
}

sub read {
    my ($class, %opts) = @_;
    my $mnt = delete $opts{mnt};
    my $pid = delete $opts{pid};
    my $file = delete $opts{file};
    %opts and croak "Unknown option(s) ". join(", ", sort keys %opts);

    unless (defined $file) {
        $mnt = "/proc" unless defined $mnt;
        croak "'$mnt' is not a proc filesystem" unless -d $mnt and (stat _)[12] == 0;
        $pid = $$ unless defined $pid;
        $file = "$mnt/$pid/mountinfo";
    }
    open my $fh, '<', $file or croak "Unable to open '$file': $!";

    my @entries;
    my %entry_by_id;
    my %entry_by_mm;
 OUT: while (<$fh>) {
        chomp;
        my @fields = split;
        my ($dash_ix) = grep $fields[$_] eq '-', 6 .. $#fields;
        unless ($dash_ix) {
            warn "dash not found inside mountinfo";
            next;
        }

        if (@fields < $dash_ix + 4) {
            warn "invalid number of fields";
            next;
        }

        s/\\([0-7]{1,3})/chr oct $1/g for @fields;

        my $entry = [ @fields[0 .. 5, $dash_ix+1 .. $#fields],
                      [ @fields[6 .. $dash_ix-1] ],
                      $., $_,
                      _key($fields[4]),
                      [] ];
        push @entries, bless $entry, 'Linux::Proc::Mountinfo::Entry';
        $entry_by_id{$entry->[0]} = $entry;

        my $old = $entry_by_mm{$entry->[2]};
        if (not $old or length($entry->[3]) < length($old->[3])) {
            $entry_by_mm{$entry->[2]} = $entry
        }
    }

    for my $entry (@entries) {
        my $bind = $entry_by_mm{$entry->[2]};
        $entry->[14] = ( $bind == $entry ? undef : $bind );

        if ($entry->[0] != $entry->[1]) {
            if (my $parent = $entry_by_id{$entry->[1]}) {
                push @{$parent->[13]}, $entry;
            }
        }

    }

    bless \@entries, $class;
}

*new = \&read;

sub at {
    my ($self, $at) = @_;
    my $key = _key $at;
    $_->[12] eq $key and return $_ for @$self;
    ()
}

sub root {
    my $self = shift;
    $_->[4] eq '/' and return $_ for @$self;
    ()
}

package Linux::Proc::Mountinfo::Entry;

sub mount_id        { shift->[ 0] }
sub parent_id       { shift->[ 1] }
sub major_minor     { shift->[ 2] }
sub root            { shift->[ 3] }
sub mount_point     { shift->[ 4] }
sub mount_options   { shift->[ 5] }
sub fs_type         { shift->[ 6] }
sub mount_source    { shift->[ 7] }
sub super_options   { shift->[ 8] }

sub optional_fields { [@{shift->[9]}] }

sub line_number     { shift->[10] }
sub line            { shift->[11] }

sub _key            { shift->[12] }

sub major           { (split /:/, shift->[2])[0] }
sub minor           { (split /:/, shift->[2])[1] }

sub children        { bless [@{shift->[13]}], 'Linux::Proc::Mountinfo' }

sub bind_source     { shift->[14] }

sub flatten {
    my $self = shift;
    my @flatten;
    my @queue = $self;
    while (@queue) {
        my $first = shift @queue;
        push @flatten, $first;
        push @queue, @{$first->[13]}
    }
    bless \@flatten, 'Linux::Proc::Mountinfo'
}

1;

__END__