1package System::Info::Linux;
2
3use strict;
4use warnings;
5
6use base "System::Info::Base";
7
8our $VERSION = "0.052";
9
10=head1 NAME
11
12System::Info::Linux - Object for specific Linux info.
13
14=head1 DESCRIPTION
15
16=head2 $si->prepare_sysinfo
17
18Use os-specific tools to find out more about the system.
19
20=cut
21
22sub prepare_sysinfo {
23    my $self = shift;
24    $self->SUPER::prepare_sysinfo;
25    $self->prepare_os;
26    $self->prepare_proc_cpuinfo or return;
27
28    for ($self->get_cpu_type) {
29	m/arm/     and do { $self->linux_arm;   last };
30	m/aarch64/ and do { $self->linux_arm;   last };
31	m/ppc/     and do { $self->linux_ppc;   last };
32	m/sparc/   and do { $self->linux_sparc; last };
33	m/s390x/   and do { $self->linux_s390x; last };
34	# default
35	$self->linux_generic;
36	}
37    return $self;
38    } # prepare_sysinfo
39
40=head2 $si->prepare_os
41
42Use os-specific tools to find out more about the operating system.
43
44=cut
45
46sub _file_info {
47    my ($file, $os) = @_;
48    open my $fh, "<", $file or return;
49    while (<$fh>) {
50	m/^\s*[;#]/ and next;
51	chomp;
52	m/\S/ or next;
53	s/^\s+//;
54	s/\s+$//;
55	if (my ($k, $v) = (m/^(.*\S)\s*=\s*(\S.*)$/)) {
56	    # Having a value prevails over being defined
57	    defined $os->{$k} and next;
58	    $v =~ s/^"\s*(.*?)\s*"$/$1/;
59	    $v =~ m{^["(]?undef(?:ined)?[")]$}i and $v = "undefined";
60	    $os->{$k} = $v;
61	    next;
62	    }
63	m/^[12][0-9]{3}(?:,\s*[12][0-9]{3})*$/ and next; # Copyright years
64	exists $os->{$_} or $os->{$_} = undef;
65	}
66    close $fh;
67    } # _file_info
68
69sub _lsb_release {
70    my $os = shift;
71
72    $ENV{SMOKE_USE_ETC} and return;
73
74    $os->{DISTRIB_ID} || $os->{DISTRIB_RELEASE} || $os->{DISTRIB_CODENAME}
75	or return;
76
77    #use DP;die DDumper $os;
78    open my $ch, "lsb_release -a 2>&1 |" or return;
79    my %map = (
80	"LSB Version"		=> "don't care",
81	"Distributor ID"	=> "DISTRIB_ID",
82	"Description"		=> "DISTRIB_DESCRIPTION",
83	"Release"		=> "DISTRIB_RELEASE",
84	"Code"			=> "DISTRIB_CODENAME",
85	);
86    while (<$ch>) {
87	chomp;
88	m/^\s*(\S.*?)\s*:\s*(.*?)\s*$/ or next;
89	$os->{$map{$1} || $1} ||= $2 unless $2 eq "n/a";
90	}
91    } # _lsb_release
92
93sub prepare_os {
94    my $self = shift;
95
96    my $etc = $ENV{SMOKE_USE_ETC} || "/etc";
97    my @dist_file = grep { -f $_ && -s _ } map {
98	-d $_ ? glob ("$_/*") : ($_)
99	} glob ("$etc/*[-_][rRvV][eE][lLrR]*"), "$etc/issue",
100		"$etc.defaults/VERSION", "$etc/VERSION", "$etc/release";
101
102    my $os = $self->_os;
103    my %os;
104    my $distro;
105    foreach my $df (@dist_file) {
106	# use "debian" out of /etc/debian-release
107	unless (defined $distro or $df =~ m/\blsb-/) {
108	    ($distro = $df) =~ s{^$etc(?:\.defaults)?/}{}i;
109	    $distro =~ s{[-_]?(?:release|version)\b}{}i;
110	    }
111	_file_info ($df, \%os);
112	}
113    _lsb_release (\%os);
114
115    keys %os or return;
116
117    foreach my $key (keys %os) {
118	my $KEY = uc $key;
119	defined $os{$key} or next;
120	exists $os{$KEY} or $os{$KEY} = $os{$key};
121	}
122
123    if ($os{DISTRIB_DESCRIPTION}) {
124	$distro = $os{DISTRIB_DESCRIPTION};
125	$os{DISTRIB_CODENAME} && $distro !~ m{\b$os{DISTRIB_CODENAME}\b}i and
126	    $distro .= " ($os{DISTRIB_CODENAME})";
127	if ($os{VERSION_ID} && $distro !~ m{\b$os{VERSION_ID}\b}i) {
128	    $distro .= " $os{VERSION_ID}";
129	    }
130	elsif ($os{DISTRIB_RELEASE} && $distro !~ m{\b$os{DISTRIB_RELEASE}\b}i) {
131	    $distro .= " $os{DISTRIB_RELEASE}";
132	    }
133	}
134    elsif ($os{PRETTY_NAME}) {
135	$distro = $os{PRETTY_NAME};          # "openSUSE 12.1 (Asparagus) (x86_64)"
136	if (my $vid = $os{VERSION_ID}) {     # wheezy 7 => 7.2
137	    my @rv;
138	    if (@rv = grep m{^$vid\.} => sort keys %os) {
139		# from /etc/debian_version
140		$rv[0] =~ m/^[0-9]+\.\w+$/ and
141		    $distro =~ s/\b$vid\b/$rv[0]/;
142		}
143	    if (!@rv && defined $os{NAME} and # CentOS Linux 7 = CentOS Linux 7.1.1503
144		 @rv = grep m{^$os{NAME} (?:(?:release|version)\s+)?$vid\.} => sort keys %os) {
145		if ($rv[0] =~ m/\s($vid\.[-.\w]+)/) {
146		    my $vr = $1;
147		    $distro =~ s/\s$vid\b/ $vr/;
148		    }
149		}
150	    }
151	$distro =~ s{\s*[-:/,]\s*Version\s*:?\s*}{ };
152	$distro =~ s/\)\s+\(\w+\)\s*$/)/;    # remove architectural part
153	$distro =~ s/\s+\(?(?:i\d86|x86_64)\)?\s*$//; # i386 i486 i586 x86_64
154	$os{VERSION_ID} && $distro !~ m{\b$os{VERSION_ID}\b}i and
155	    $distro .= " $os{VERSION_ID}";
156	}
157    elsif ($os{VERSION} && $os{NAME}) {
158	$distro = qq{$os{NAME} $os{VERSION}};
159	}
160    elsif ($os{VERSION} && $os{CODENAME}) {
161	if (my @welcome = grep s{^\s*Welcome\s+to\s+(\S*$distro\S*)\b.*}{$1}i => keys %os) {
162	    $distro = $welcome[0];
163	    }
164	$distro .= qq{ $os{VERSION}};
165	$distro =~ m/\b$os{CODENAME}\b/ or
166	    $distro .= qq{ ($os{CODENAME})};
167	}
168    elsif ($os{MAJORVERSION} && defined $os{MINORVERSION}) {
169	-d "/usr/syno" || "@dist_file" =~ m{^\S*/VERSION$} and $distro .= "DSM";
170	$distro .= qq{ $os{MAJORVERSION}.$os{MINORVERSION}};
171	$os{BUILDNUMBER}    and $distro .= qq{-$os{BUILDNUMBER}};
172	$os{SMALLFIXNUMBER} and $distro .= qq{-$os{SMALLFIXNUMBER}};
173	}
174    elsif ($os{DISTRIBVER} && exists $os{NETBSDSRCDIR}) {
175	(my $dv = $os{DISTRIBVER}) =~ tr{ ''"";}{}d;
176	$distro .= qq{ NetBSD $dv};
177	}
178    else {
179	# /etc/issue:
180	#  Welcome to SUSE LINUX 10.0 (i586) - Kernel \r (\l).
181	#  Welcome to openSUSE 10.2 (i586) - Kernel \r (\l).
182	#  Welcome to openSUSE 10.2 (X86-64) - Kernel \r (\l).
183	#  Welcome to openSUSE 10.3 (i586) - Kernel \r (\l).
184	#  Welcome to openSUSE 10.3 (X86-64) - Kernel \r (\l).
185	#  Welcome to openSUSE 11.1 - Kernel \r (\l).
186	#  Welcome to openSUSE 11.2 "Emerald" - Kernel \r (\l).
187	#  Welcome to openSUSE 11.3 "Teal" - Kernel \r (\l).
188	#  Welcome to openSUSE 11.4 "Celadon" - Kernel \r (\l).
189	#  Welcome to openSUSE 12.1 "Asparagus" - Kernel \r (\l).
190	#  Welcome to openSUSE 12.2 "Mantis" - Kernel \r (\l).
191	#  Welcome to openSUSE 12.3 "Dartmouth" - Kernel \r (\l).
192	#  Welcome to openSUSE 13.1 "Bottle" - Kernel \r (\l).
193	#  Welcome to openSUSE 13.2 "Harlequin" - Kernel \r (\l).
194	#  Welcome to openSUSE Leap 42.1 - Kernel \r (\l).
195	#  Welcome to openSUSE 20151218 "Tumbleweed" - Kernel \r (\l).
196	#  Welcome to SUSE Linux Enterprise Server 11 SP1 for VMware  (x86_64) - Kernel \r (\l).
197	#  Ubuntu 10.04.4 LTS \n \l
198	#  Debian GNU/Linux wheezy/sid \n \l
199	#  Debian GNU/Linux 6.0 \n \l
200	#  CentOS release 6.4 (Final)
201	# /etc/redhat-release:
202	#  CentOS release 5.7 (Final)
203	#  CentOS release 6.4 (Final)
204	#  Red Hat Enterprise Linux ES release 4 (Nahant Update 2)
205	# /etc/debian_version:
206	#  6.0.4
207	#  wheezy/sid
208	#  squeeze/sid
209
210	my @key = sort keys %os;
211	s/\s*\\[rln].*// for @key;
212
213	my @vsn = grep m/^[0-9.]+$/ => @key;
214	#$self->{__X__} = { os => \%os, key => \@key, vsn => \@vsn };
215
216	if (my @welcome = grep s{^\s*Welcome\s+to\s+}{}i => @key) {
217	    ($distro = $welcome[0]) =~ s/"([^"]+)"/($1)/;
218	    }
219	elsif (my @rel  = grep m{\brelease\b}i => @key) {
220	    @rel > 1 && $rel[0] =~ m/^Enterprise Linux Enterprise/
221		     && $rel[1] =~ m/^Oracle Linux/ and shift @rel;
222	    $distro = $rel[0];
223	    $distro =~ s/ *release//;
224	    $distro =~ s/Red Hat Enterprise Linux/RHEL/; # Too long for subject
225	    # RHEL ES 4 (Nahant Update 2) => RHEL Server 4.2 (Nahant)
226	    $distro =~ s/^RHEL ES (\d+)\s+(.*)\s+Update\s+(\d+)/RHEL Server $1.$3 $2/;
227	    }
228	elsif ( my @lnx  = grep m{\bLinux\b}i => @key ) {
229	    $distro = $lnx[0];
230	    }
231	elsif ( $distro && @vsn ) {
232	    $distro .= "-$vsn[0]";
233	    }
234	else {
235	    $distro = $key[0];
236	    }
237	$distro =~ s/\s+-\s+Kernel.*//i;
238	}
239    if ($distro =~ s/^\s*(.*\S)\s*$/$1/) {
240	$self->{__distro} = $distro;
241	$os .= " [$distro]";
242	}
243    $self->{__release_info} = \%os;
244    $self->{__os} = $os;
245    } # prepare_os
246
247=head2 $si->linux_generic
248
249Check C</proc/cpuinfo> for these keys:
250
251=over
252
253=item "processor"  (count occurrence for __cpu_count)
254
255=item "model name" (part of __cpu)
256
257=item "vendor_id"  (part of __cpu)
258
259=item "cpu mhz"    (part of __cpu)
260
261=item "cpu cores"  (add values to add to __cpu_count)
262
263=back
264
265=cut
266
267sub linux_generic {
268    my $self = shift;
269
270    my $n_phys_id   = $self->count_unique_in_cpuinfo (qr/^physical id\s+:/) || 0;
271    my $n_core_id   = $self->count_unique_in_cpuinfo (qr/^core id\s+:/)     || 0;
272    my $n_processor = $self->count_unique_in_cpuinfo (qr/^processor\s+:/)   || 0;
273    my $n_cpu       = $n_phys_id || $n_core_id || $n_processor;
274
275    # ::diag"Np: $n_phys_id, NC: $n_core_id, NP: $n_processor, NC: $n_cpu";
276    $self->{__cpu_count} = $n_cpu;
277
278    my @parts = ("model name", "vendor_id", "cpu mhz");
279    my %info = map { ($_ => $self->from_cpuinfo ($_)) } @parts;
280    $self->{__cpu} = sprintf "%s (%s %.0fMHz)", map { $info{$_} } @parts;
281
282    if ($n_phys_id) {
283	$n_processor > $n_phys_id and
284	    $self->{__cpu_count} .= " [$n_processor cores]";
285	return;
286	}
287    if ($n_core_id) {
288	$n_processor > $n_core_id and
289	    $self->{__cpu_count} .= " [$n_processor cores]";
290	return;
291	}
292
293    my $n_cores = 0;
294    my $core_id = 0;
295    my %cores;
296    for my $cores (grep m/(cpu cores|core id)\s*:\s*\d+/ => $self->_proc_cpuinfo) {
297	my ($tag, $count) = $cores =~ m/^(.*\S)\s*:\s*(\d+)/ or next;
298	if ($tag eq "core id") {
299	    $core_id = $count;
300	    }
301	else {
302	    $cores{$core_id} = $count;
303	    }
304	}
305    $n_cores += $cores{$_} for keys %cores;
306
307    $n_cores > $n_cpu and $self->{__cpu_count} .= " [$n_cores cores]";
308    } # _linux_generic
309
310=head2 $si->linux_arm
311
312Check C</proc/cpuinfo> for these keys:
313
314=over
315
316=item "processor"  (count occurrence for __cpu_count)
317
318=item "Processor" (part of __cpu)
319
320=item "BogoMIPS"  (part of __cpu)
321
322=back
323
324=cut
325
326sub linux_arm {
327    my $self = shift;
328
329    $self->{__cpu_count} = $self->count_in_cpuinfo (qr/^processor\s+:\s+/i);
330
331    my $cpu  = $self->from_cpuinfo ("Processor") ||
332	       $self->from_cpuinfo ("Model[_ ]name");
333    my $bogo = $self->from_cpuinfo ("BogoMIPS");
334    my $mhz  = 100 * int (($bogo + 50) / 100);
335    $cpu =~ s/\s+/ /g;
336    $mhz and $cpu .= " ($mhz MHz)";
337    $self->{__cpu} = $cpu;
338    } # _linux_arm
339
340=head2 $si->linux_ppc
341
342Check C</proc/cpuinfo> for these keys:
343
344=over
345
346=item "processor"  (count occurrence for __cpu_count)
347
348=item "cpu"     (part of __cpu)
349
350=item "machine" (part of __cpu)
351
352=item "clock"   (part of __cpu)
353
354=item "detected" (alters machine if present)
355
356=back
357
358=cut
359
360sub linux_ppc {
361    my $self = shift;
362
363    $self->{__cpu_count} = $self->count_in_cpuinfo (qr/^processor\s+:\s+/);
364
365    my @parts = qw( cpu machine clock );
366    my %info = map { ($_ => $self->from_cpuinfo ($_)) } @parts;
367    if ($info{detected} = $self->from_cpuinfo ("detected as")){
368	$info{detected} =~ s/.*(\b.+Mac G\d).*/$1/;
369	$info{machine} = $info{detected};
370	}
371
372    $self->{__cpu} = sprintf "%s %s (%s)", map { $info{$_} } @parts;
373    } # linux_ppc
374
375=head2 $si->linux_sparc
376
377Check C</proc/cpuinfo> for these keys:
378
379=over
380
381=item "processor"  (count occurrence for __cpu_count)
382
383=item "cpu"        (part of __cpu)
384
385=item "Cpu0ClkTck" (part of __cpu)
386
387=back
388
389=cut
390
391sub linux_sparc {
392    my $self = shift;
393
394    $self->{__cpu_count} = $self->from_cpuinfo ("ncpus active");
395
396    my @parts = qw( cpu Cpu0ClkTck );
397    my %info  = map { ($_ => $self->from_cpuinfo ($_)) } @parts;
398    my $cpu   = $info{cpu};
399    $info{Cpu0ClkTck} and
400	$cpu .=  sprintf " (%.0fMHz)", hex ($info{Cpu0ClkTck}) / 1_000_000;
401    $self->{__cpu} = $cpu;
402    } # linux_sparc
403
404=head2 $si->linux_s390x
405
406Check C</proc/cpuinfo> for these keys:
407
408=over
409
410=item "processor"  (count occurrence for __cpu_count)
411
412=item "Processor" (part of __cpu)
413
414=item "BogoMIPS"  (part of __cpu)
415
416=back
417
418=cut
419
420sub linux_s390x {
421    my $self = shift;
422
423    $self->{__cpu_count} = $self->count_in_cpuinfo (qr/^processor\s+\d+:\s+/i);
424
425    my $cpu  = $self->from_cpuinfo ("vendor_id") ||
426	       $self->from_cpuinfo ("Processor") ||
427	       $self->from_cpuinfo ("Model[_ ]name");
428    my $bogo = $self->from_cpuinfo (qr{BogoMIPS(?:\s*per[ _]CPU)?}i);
429    my $mhz  = 100 * int (($bogo + 50) / 100);
430    $cpu =~ s/\s+/ /g;
431    $mhz and $cpu .= " ($mhz MHz)";
432    $self->{__cpu} = $cpu;
433    } # _linux_s390x
434
435=head2 $si->prepare_proc_cpuinfo
436
437Read the complete C<< /proc/cpuinfo >>.
438
439=cut
440
441sub prepare_proc_cpuinfo {
442    my $self = shift;
443
444    if (open my $pci, "<", "/proc/cpuinfo") {
445	chomp (my @pci = <$pci>);
446	s/[\s\xa0]+/ /g for @pci;
447	s/ $//          for @pci;
448	$self->{__proc_cpuinfo} = \@pci;
449	close $pci;
450	return 1;
451	}
452    } # prepare_proc_cpuinfo
453
454=head2 $si->count_in_cpuinfo ($regex)
455
456Returns the number of lines $regex matches for.
457
458=cut
459
460sub count_in_cpuinfo {
461    my ($self, $regex) = @_;
462
463    return scalar grep /$regex/, $self->_proc_cpuinfo;
464    } # count_in_cpuinfo
465
466=head2 $si->count_unique_in_cpuinfo ($regex)
467
468Returns the number of lines $regex matches for.
469
470=cut
471
472sub count_unique_in_cpuinfo {
473    my ($self, $regex) = @_;
474
475    my %match = map { $_ => 1 } grep /$regex/ => $self->_proc_cpuinfo;
476    return scalar keys %match;
477    } # count_unique_in_cpuinfo
478
479=head2 $si->from_cpuinfo ($key)
480
481Returns the first value of that key in C<< /proc/cpuinfo >>.
482
483=cut
484
485sub from_cpuinfo {
486    my ($self, $key) = @_;
487
488    my ($first) = grep m/^\s*$key\s*[:=]\s*/i => $self->_proc_cpuinfo;
489    defined $first or $first = "";
490    $first =~ s/^\s*$key\s*[:=]\s*//i;
491    return $first;
492    } # from_cpuinfo
493
4941;
495
496__END__
497
498=head1 COPYRIGHT AND LICENSE
499
500(c) 2016-2018, Abe Timmerman & H.Merijn Brand, All rights reserved.
501
502With contributions from Jarkko Hietaniemi, Campo Weijerman, Alan Burlison,
503Allen Smith, Alain Barbet, Dominic Dunlop, Rich Rauenzahn, David Cantrell.
504
505This library is free software; you can redistribute it and/or modify
506it under the same terms as Perl itself.
507
508See:
509
510=over 4
511
512=item * L<http://www.perl.com/perl/misc/Artistic.html>
513
514=item * L<http://www.gnu.org/copyleft/gpl.html>
515
516=back
517
518This program is distributed in the hope that it will be useful,
519but WITHOUT ANY WARRANTY; without even the implied warranty of
520MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
521
522=cut
523