File Coverage

blib/lib/RPi/SysInfo.pm

Criterion	Covered	Total	%
statement	144	154	93.5
branch	72	88	81.8
condition	14	21	66.6
subroutine	24	30	80.0
pod	10	10	100.0
total	264	303	87.1

package RPi::SysInfo;

use strict;
use warnings;

use Carp qw(croak);

our $VERSION = '1.02';

require XSLoader;
XSLoader::load('RPi::SysInfo', $VERSION);

use Exporter qw(import);

our @EXPORT_OK = qw(
    core_temp
    cpu_percent
    mem_percent
    gpio_info
    raspi_config
    network_info
    file_system
    pi_details
    pi_model
);

our %EXPORT_TAGS;
$EXPORT_TAGS{all} = [@EXPORT_OK];

sub new {
    return bless {}, shift;
}
sub core_temp {
    shift if $_[0] && $_[0] =~ /RPi::/;

    my ($degree) = @_;

    $degree //= 'c';

    my $temp = _core_temp_c();

    return '' if ! defined $temp;

    if ($degree eq 'f' || $degree eq 'F'){
        $temp = ($temp * 1.8) + 32;
    }

    chomp $temp;
    return $temp;
}
sub cpu_percent {
    return _format(cpuPercent());
}
sub gpio_info {
    shift if $_[0] && $_[0] =~ /RPi::/;

    my ($pins) = @_;

    $pins = ! defined $pins
        ? ''
        : join ",", @$pins;

    # raspi-gpio was removed from current Raspberry Pi OS in favour of pinctrl,
    # and never existed for the Pi 5 / RP1. Prefer pinctrl, falling back to
    # raspi-gpio on older systems that still ship it. Both accept the same
    # "get [pin[,pin...]]" invocation.

    my $tool = _gpio_tool();

    return '' if ! defined $tool;

    my $info = _run("$tool get $pins");

    chomp $info;
    return $info;
}
sub file_system {
    my $fs_info = _run('df') . "\n";
    $fs_info .= _slurp('/proc/swaps') // '';
    return $fs_info;
}
sub mem_percent {
    return _format(memPercent());
}
sub network_info {

    # ifconfig (net-tools) is the legacy default, but modern Raspberry Pi OS
    # Lite ships without it, so fall back to `ip addr`, which is always present.
    # Both forms carry inet/inet6 lines.

    my $tool = _net_tool();

    return '' if ! defined $tool;

    my $netinfo = _run($tool);

    chomp $netinfo;
    return $netinfo;
}
sub pi_details {

    my $details;

    $details = "\n"
             . _run('cat /sys/firmware/devicetree/base/model')
             . "\n\n"
             . _run('cat /etc/os-release | head -4')
             . "\n"
             . _run('uname -a')
             . "\n"
             . _run('cat /proc/cpuinfo | tail -3')
             . "Board           : " . pi_model() . "\n"
             . "SoC / RAM       : " . _board_summary() . "\n"
             . "Throttled flag  : " . _run('vcgencmd get_throttled')
             . "Camera          : " . _camera_info() . "\n";

    return $details;
}
sub pi_model {
    shift if $_[0] && $_[0] =~ /RPi::/;

    # Normalized Raspberry Pi marketing name, e.g. "Raspberry Pi 5 Model B Rev
    # 1.1". The devicetree model is authoritative on the Pi 0-5, so prefer it,
    # falling back to a /proc/cpuinfo Revision-code decode, then to 'Unknown'.

    my $model = _slurp('/sys/firmware/devicetree/base/model');

    if (defined $model){
        $model =~ s/\0//g;              # Devicetree strings are NUL-terminated.
        $model =~ s/^\s+|\s+$//g;
        return $model if length $model;
    }

    my $info = _decode_revision(_cpuinfo_field('Revision'));

    return $info->{name} if defined $info->{name};

    return 'Unknown';
}
sub raspi_config {
    my $config = _run('vcgencmd get_config int');
    $config .= _run('vcgencmd get_config str');

    # config.txt moved from /boot to /boot/firmware on Bookworm and later (the
    # old path now holds only a "this file has moved" stub), so resolve the
    # real location before appending the user's non-comment directives.

    my $config_file = _config_file();

    if (defined $config_file){
        $config .= _run("grep -E -v '^\\s*(#|^\$)' $config_file");
    }

    chomp $config;
    return $config;
}

sub _board_summary {
    # Human-readable decode of the SoC, RAM and RP1 presence pulled from the
    # /proc/cpuinfo Revision code. Used to enrich pi_details(). Returns
    # 'unknown' when the revision can't be decoded.

    my $info = _decode_revision(_cpuinfo_field('Revision'));

    my @parts;

    push @parts, $info->{soc}          if defined $info->{soc};
    push @parts, $info->{mem}          if defined $info->{mem};
    push @parts, 'RP1'                 if $info->{rp1};
    push @parts, $info->{manufacturer} if defined $info->{manufacturer};

    return @parts ? join(', ', @parts) : 'unknown';
}
sub _camera_info {
    # Legacy firmware (Pi 0-4 on Bullseye and earlier) answered
    # `vcgencmd get_camera` with "supported=N detected=N". On Bookworm and the
    # Pi 5 that command was removed and camera support moved to libcamera, so
    # fall back to a libcamera probe. Returns a one-line string (no newline).

    local $SIG{__WARN__} = sub {
        my $warning = shift;
        warn $warning if $warning !~ /Can't exec "vcgencmd"/;
    };

    my $legacy = _run('vcgencmd get_camera');

    if ($legacy =~ /supported=/){
        $legacy =~ s/\s+$//;
        return $legacy;
    }

    my $tool = _camera_tool();

    if (defined $tool){
        my $list = _run("$tool --list-cameras 2>/dev/null");

        return 'detected (libcamera)' if $list =~ /Available cameras/i;
        return 'none detected (libcamera)';
    }

    return 'not detected';
}
sub _camera_tool {
    # libcamera's listing utility: rpicam-hello on Bookworm and later, renamed
    # from the Bullseye-era libcamera-hello.

    return _first_tool(qw(rpicam-hello libcamera-hello));
}
sub _config_file {
    # Locate the active config.txt. Bookworm and later moved it to
    # /boot/firmware/config.txt; older systems keep it at /boot/config.txt.

    for my $file ('/boot/firmware/config.txt', '/boot/config.txt'){
        return $file if -f $file;
    }

    return undef;
}
sub _core_temp_c {
    # Core temperature in Celsius as a number, or undef if unavailable. Prefers
    # vcgencmd (the value the Pi tooling reports), falling back to the kernel
    # thermal zone on systems without vcgencmd.

    local $SIG{__WARN__} = sub {
        my $warning = shift;
        warn $warning if $warning !~ /Can't exec "vcgencmd"/;
    };

    my $temp = _run('vcgencmd measure_temp');

    return $1 if $temp =~ /temp=([\d.]+)/;

    # /sys/class/thermal/thermal_zone0/temp reports millidegrees Celsius.

    my $milli = _slurp('/sys/class/thermal/thermal_zone0/temp');

    return $1 / 1000 if defined $milli && $milli =~ /^(\d+)/;

    return undef;
}
sub _cpuinfo_field {
    my ($field) = @_;

    croak "_cpuinfo_field() requires a field name\n" if ! defined $field;

    my $cpuinfo = _slurp('/proc/cpuinfo');

    return undef if ! defined $cpuinfo;

    for my $line (split /\n/, $cpuinfo){
        return $1 if $line =~ /^\Q$field\E\s*:\s*(.+?)\s*$/;
    }

    return undef;
}
sub _decode_revision {
    my ($rev) = @_;

    return {} if ! defined $rev;

    $rev =~ s/^\s+|\s+$//g;

    return {} if $rev !~ /^[0-9a-fA-F]+$/;

    $rev = hex($rev);

    my %info;

    if ($rev & 0x800000){
        # New-style revision code (Pi 2 and later, plus late Pi 1 boards).
        my $type  = ($rev >> 4)  & 0xff;
        my $proc  = ($rev >> 12) & 0x0f;
        my $mfr   = ($rev >> 16) & 0x0f;
        my $mem   = ($rev >> 20) & 0x07;
        my $minor = $rev & 0x0f;

        my %types = (
            0x00 => 'A',         0x01 => 'B',          0x02 => 'A+',
            0x03 => 'B+',        0x04 => '2 Model B',  0x06 => 'Compute Module 1',
            0x08 => '3 Model B', 0x09 => 'Zero',       0x0a => 'Compute Module 3',
            0x0c => 'Zero W',    0x0d => '3 Model B+', 0x0e => '3 Model A+',
            0x10 => 'Compute Module 3+', 0x11 => '4 Model B',
            0x12 => 'Zero 2 W',  0x13 => '400',        0x14 => 'Compute Module 4',
            0x15 => 'Compute Module 4S', 0x17 => '5 Model B',
            0x18 => 'Compute Module 5',  0x19 => '500',
        );
        my %procs = (
            0 => 'BCM2835', 1 => 'BCM2836', 2 => 'BCM2837',
            3 => 'BCM2711', 4 => 'BCM2712',
        );
        my %mfrs = (
            0 => 'Sony UK', 1 => 'Egoman', 2 => 'Embest',
            3 => 'Sony Japan', 4 => 'Embest', 5 => 'Stadium',
        );

        $info{new_style}    = 1;
        $info{type}         = $types{$type};
        $info{soc}          = $procs{$proc};
        $info{manufacturer} = $mfrs{$mfr};
        $info{revision}     = $minor;
        $info{mem}          = _mem_human(256 << $mem);
        $info{rp1}          = $proc == 4 ? 1 : 0;
        $info{name}         = defined $types{$type}
            ? "Raspberry Pi $types{$type}"
            : undef;
    }
    else {
        # Old-style revision code (original Pi 1 / early boards). A small
        # lookup of the common ones; everything else is left to the devicetree
        # model. All old-style boards are BCM2835, pre-RP1.
        my %old = (
            0x0002 => ['B',  '256MB'], 0x0003 => ['B',  '256MB'],
            0x0004 => ['B',  '256MB'], 0x0005 => ['B',  '256MB'],
            0x0006 => ['B',  '256MB'], 0x0007 => ['A',  '256MB'],
            0x0008 => ['A',  '256MB'], 0x0009 => ['A',  '256MB'],
            0x000d => ['B',  '512MB'], 0x000e => ['B',  '512MB'],
            0x000f => ['B',  '512MB'], 0x0010 => ['B+', '512MB'],
            0x0011 => ['Compute Module 1', '512MB'],
            0x0012 => ['A+', '256MB'], 0x0013 => ['B+', '512MB'],
            0x0014 => ['Compute Module 1', '512MB'],
            0x0015 => ['A+', '256MB'],
        );

        $info{new_style} = 0;
        $info{soc}       = 'BCM2835';
        $info{rp1}       = 0;

        if (my $entry = $old{$rev}){
            $info{type} = $entry->[0];
            $info{mem}  = $entry->[1];
            $info{name} = "Raspberry Pi $entry->[0]";
        }
    }

    return \%info;
}
sub _first_tool {
    # Returns the first of the given executable names found on PATH, else undef.

    for my $tool (@_){
        for my $dir (split /:/, $ENV{PATH} // ''){
            return $tool if -x "$dir/$tool";
        }
    }

    return undef;
}
sub _format {
    croak "_format() requires a float/double sent in\n" if ! defined $_[0];
    return sprintf("%.2f", $_[0]);
}
sub _gpio_tool {
    # Locate a GPIO query tool on PATH. pinctrl is the current Raspberry Pi OS
    # utility; raspi-gpio is the legacy one kept here as a fallback.

    return _first_tool(qw(pinctrl raspi-gpio));
}
sub _mem_human {
    my ($mb) = @_;

    return undef if ! defined $mb;

    return $mb % 1024 == 0
        ? ($mb / 1024) . 'GB'
        : $mb . 'MB';
}
sub _net_tool {
    # Locate a network-interface query command. ifconfig (net-tools) is the
    # legacy default; fall back to `ip addr` on systems without it.

    return 'ifconfig' if defined _first_tool('ifconfig');
    return 'ip addr'  if defined _first_tool('ip');

    return undef;
}
sub _run {
    my ($cmd) = @_;

    croak "_run() requires a command string\n" if ! defined $cmd;

    my $out = `$cmd`;

    return defined $out ? $out : '';
}
sub _slurp {
    my ($file) = @_;

    croak "_slurp() requires a file path\n" if ! defined $file;

    open my $fh, '<', $file or return undef;
    local $/;
    my $data = <$fh>;
    close $fh;

    return $data;
}

1;
__END__