lsblk fix for Linux 4.8

lsblk.pl

#!/usr/bin/env perl

=head1 Fix lsblk on Linux 4.8

On Linux 4.8 the order of devices is screwed up. Let's sort it manually.

=cut

use warnings;
use strict;
use 5.010;

use utf8;
use open IO     => ':encoding(UTF-8)';
use open ':std' => ':encoding(UTF-8)';

# Parse and load the lsblk tree into a nested hash.
sub parse_devices {
    my (%args) = @_;
    my @lines = @{ $args{lines} };
    my $prefix = $args{prefix} // 0;

    my %device_trees = ();

    # Parse each top-level node. We'll deal with the children later.
    my $this_device = undef;
    for (@lines) {
        if (/^[^a-zA-Z]{$prefix}[a-zA-Z]/) {

            # It's a new top-level node, let's initialize it.
            $this_device = $_;
            $device_trees{$this_device} = [];
        } else {

            # It's a child node, let's append it to its parent.
            push @{ $device_trees{$this_device} }, $_;
        }
    }

    # So far we have a single-level structure, a hash of arrays. We'd
    # like to turn these arrays into nested hashes. Let's do it by
    # calling this function recursively on each subtree.
    for my $dev (keys %device_trees) {
        if (@{ $device_trees{$dev} }) {

            # Replace the flat array with a logically structured subtree.
            $device_trees{$dev} = parse_devices(
                lines  => $device_trees{$dev},
                prefix => $prefix + 2,           # the indent used by lsblk
            );
        } else {

            # Even if the node is childless, we need to turn it from
            # an empty array to an empty hash to make the structure
            # consistent.
            $device_trees{$dev} = {};
        }
    }

    return \%device_trees;
}

# Pretty print the device tree in a sorted manner.
sub print_devices {
    my (%args) = @_;

    my %devices = %{ $args{devices} };

    sub compare_sans_indent {

        # Compare only the part follwing the tree drawn by lsblk, i.e.
        # ignore every leading non-alpha character during the
        # comparison.
        my $re = qr/^[^a-zA-Z]*/;
        $a =~ s/$re//r cmp $b =~ s/$re//r;
    }

    for (sort compare_sans_indent keys %devices) {

        # The actual lines are stored in our keys.
        print;

        # Descend into the subtree and print it before continuing on
        # this level.
        print_devices(devices => $devices{$_});
    }
}

open(my $lsblk_fh, '-|', "/bin/lsblk", @ARGV);
my @lsblk = <$lsblk_fh>;
close $lsblk_fh;

my $devices = parse_devices(lines => \@lsblk);
print_devices(devices => $devices);