view release on metacpan or  search on metacpan

lib/Linux/Cpuinfo.pm  view on Meta::CPAN

=over 4

=cut

use 5.006;

use strict;
use warnings;

use Carp;


our $AUTOLOAD;

our  $VERSION = '1.12';

$VERSION = eval $VERSION;

=item cpuinfo

Returns a blessed object suitable for calling the rest of the methods on or
a false value if for some reason C</proc/cpuinfo> cant be opened.  The first
argument can be an alternative file that provides identical information.  You
may also supply a hashref containing other arguments - the valid keys are

=over 2

=item NoFatal

The default behaviour is for the method to croak if an attribute is requested
that is not available on this particular CPU.  If this argument is supplied
with a true value then the method will return undef instead.  

=back

=cut

sub cpuinfo
{
    my ( $proto, $file, $args ) = @_;

    my $class = ref($proto) || $proto;

    my $self;

    if ( $file and ref($file) and ref($file) eq 'HASH' )
    {
        $args = $file;
        $file = undef;
    }

    $file ||= '/proc/cpuinfo';

    if ( -e $file and -f $file )
    {

        if ( open( CPUINFO, $file ) )
        {
            $self = {};

            local $/ = '';

            $self->{_private}->{num_cpus} = 0;

            $self->{_cpuinfo} = [];

            while (<CPUINFO>)
            {
                chomp;


                my $cpuinfo = {};

                foreach my $cpuline ( split /\n/ )
                {
                    my ( $attribute, $value ) = split /\s*:\s*/, $cpuline;

                    $attribute =~ s/\s+/_/;
                    $attribute = lc($attribute);

                    if ( $value && $value =~ /^(no|not available|yes)$/ )
                    {
                        $value = $value eq 'yes' ? 1 : 0;
                    }

                    if ( $attribute eq 'flags' )
                    {
                        @{ $cpuinfo->{flags} } = split / /, $value;
                    }
                    else
                    {
                        $cpuinfo->{$attribute} = $value;
                    }

                }
                # This is a lot uglier than it needs to be. The perl 6
                # version is 6 lines.
                # It seems that single core arm6 or 7 cores highlight
                # a bug where there is a spurious \n in there
                # The alert will correctly surmise this breaks for assymetric 
                # cpus
                
                my $ok_to_add = 1;
                if ( @{ $self->{_cpuinfo} } )
                {
                   if (keys %{$self->{_cpuinfo}->[-1]->{_data}} != keys %{$cpuinfo} )
                   {
                      foreach my $key ( keys %{$cpuinfo} )
                      {
                         $self->{_cpuinfo}->[-1]->{_data}->{$key} = $cpuinfo->{$key};
                      }
                      $ok_to_add = 0;
                   }
                }
                if ( $ok_to_add )
                {
                   my $cpuinfo_cpu = Linux::Cpuinfo::Cpu->new( $cpuinfo, $args );
                   $self->{_private}->{num_cpus}++;
                   push @{ $self->{_cpuinfo} }, $cpuinfo_cpu;
                }
            }