Merge ~sylvain-pineau/plainbox-provider-checkbox:inxi_2021_07_21 into plainbox-provider-checkbox:master

Proposed by Sylvain Pineau
Status: Merged
Approved by: Sylvain Pineau
Approved revision: 24af188e19afb22898301d5a30e498b0daf980c3
Merged at revision: 5d9b74b71d0e883bce1b1300e580f79ada78a7e7
Proposed branch: ~sylvain-pineau/plainbox-provider-checkbox:inxi_2021_07_21
Merge into: plainbox-provider-checkbox:master
Diff against target: 45453 lines (+26072/-18358)
1 file modified
bin/inxi_snapshot (+26072/-18358)
Reviewer Review Type Date Requested Status
Maciej Kisielewski (community) Approve
Review via email: mp+408945@code.launchpad.net

Description of the change

Version refresh of the INXI system information tool

The previous snapshot was from 2018 and was missing some CPU IDs

Tested on AMD64

To post a comment you must log in.
Revision history for this message
Maciej Kisielewski (kissiel) wrote :

+1

review: Approve

Preview Diff

[H/L] Next/Prev Comment, [J/K] Next/Prev File, [N/P] Next/Prev Hunk
1diff --git a/bin/inxi_snapshot b/bin/inxi_snapshot
2index 5928ca5..6c4d37b 100755
3--- a/bin/inxi_snapshot
4+++ b/bin/inxi_snapshot
5@@ -1,11 +1,11 @@
6 #!/usr/bin/env perl
7 ## infobash: Copyright (C) 2005-2007 Michiel de Boer aka locsmif
8-## inxi: Copyright (C) 2008-2018 Harald Hope
9+## inxi: Copyright (C) 2008-2021 Harald Hope
10 ## Additional features (C) Scott Rogers - kde, cpu info
11 ## Further fixes (listed as known): Horst Tritremmel <hjt at sidux.com>
12 ## Steven Barrett (aka: damentz) - usb audio patch; swap percent used patch
13-## Jarett.Stevens - dmidecode -M patch for older systems with the /sys
14-##
15+## Jarett.Stevens - dmidecode -M patch for older systems without /sys machine
16+##
17 ## License: GNU GPL v3 or greater
18 ##
19 ## You should have received a copy of the GNU General Public License
20@@ -13,83 +13,106 @@
21 ##
22 ## If you don't understand what Free Software is, please read (or reread)
23 ## this page: http://www.gnu.org/philosophy/free-sw.html
24+##
25+## DEVS: NOTE: geany/scite folding is picky. Leave 1 space after # or it breaks!
26
27 use strict;
28 use warnings;
29 # use diagnostics;
30 use 5.008;
31
32-use Cwd qw(abs_path); # qw(abs_path);#abs_path realpath getcwd
33+## Perl 7 things for testing: depend on Perl 5.032
34+# use 5.032;
35+# use compat::perl5; # act like Perl 5's defaults
36+# no feature qw(indirect);
37+# no multidimensional;
38+# no bareword::filehandles;
39+
40+use Cwd qw(abs_path); # #abs_path realpath getcwd
41 use Data::Dumper qw(Dumper); # print_r
42-use File::Find;
43+# NOTE: load in SystemDebugger unless encounter issues with require/import
44+# use File::Find;
45+use File::stat; # needed for Xorg.0.log file mtime comparisons
46 use Getopt::Long qw(GetOptions);
47-# Note: default auto_abbrev is enabled, that's fine
48+# Note: default auto_abbrev is enabled
49 Getopt::Long::Configure ('bundling', 'no_ignore_case',
50 'no_getopt_compat', 'no_auto_abbrev','pass_through');
51-use POSIX qw(uname strftime ttyname);
52-# use feature qw(state);
53+use POSIX qw(ceil uname strftime ttyname);
54+# use Benchmark qw(:all);_
55+# use Devel::Size qw(size total_size);
56+# use feature qw(say state); # 5.10 or newer Perl
57+
58+### INITIALIZE VARIABLES ###
59
60 ## INXI INFO ##
61 my $self_name='inxi';
62-my $self_version='3.0.27';
63-my $self_date='2018-10-14';
64+my $self_version='3.3.06';
65+my $self_date='2021-07-21';
66 my $self_patch='00';
67 ## END INXI INFO ##
68
69-### INITIALIZE VARIABLES ###
70+my ($b_pledge,@pledges);
71+if (eval {require OpenBSD::Pledge}){
72+ OpenBSD::Pledge->import();
73+ $b_pledge = 1;
74+ # cpath/wpath: dir/files .inxi, --debug > 9, -c 9x, -w/W;
75+ # dns/inet: ftp upload --debug > 20; exec/proc/rpath: critical;
76+ # prot_exec: Perl import; getpw: perl getpwuid() -c 9x, Net::FTP --debug > 20;
77+ # stdio: default; error: debugging pledge/perl
78+ # tested. not required: mcast pf ps recvfd sendfd tmppath tty unix vminfo;
79+ # Pledge removal: OptionsHandler::post_process() [dns,inet,cpath,getpw,wpath];
80+ # SelectColors::set_selection() [getpw]
81+ @pledges = qw(cpath dns exec getpw inet proc prot_exec rpath wpath);
82+ pledge(@pledges);
83+}
84
85 ## Self data
86-my ($self_path, $user_config_dir, $user_config_file,$user_data_dir);
87+my ($self_path,$user_config_dir,$user_config_file,$user_data_dir);
88+
89+## Hashes
90+my (%alerts,%build_prop,%client,%colors,%disks_bsd,%dboot,%devices,%dl,
91+%dmmapper,%force,%loaded,%mapper,%program_values,%rows,%sensors_raw,
92+%service_tool,%show,%sysctl,%system_files,%usb);
93+
94+## System Arrays
95+my (@app,@dmi,@gpudata,@ifs,@ifs_bsd,@paths,@ps_aux,@ps_cmd,@ps_gui,
96+@sensors_exclude,@sensors_use,@uname);
97+
98+## Disk/Logical/Partition/RAID arrays
99+my (@btrfs_raid,@glabel,@labels,@lsblk,@lvm,@lvm_raid,@md_raid,@partitions,
100+@proc_partitions,@raw_logical,@soft_raid,@swaps,@uuids,@zfs_raid);
101
102 ## Debuggers
103-my $debug=0;
104-my (@t0,$end,$start,$fh_l,$log_file); # log file handle, file
105-my ($b_hires,$t1,$t2,$t3) = (0,0,0,0);
106+my %debugger = ('level' => 0);
107+my (@dbg,%fake,@t0);
108+my ($b_hires,$b_log,$b_log_colors,$b_log_full);
109+my ($end,$start,$fh_l,$log_file); # log file handle, file
110+my ($t1,$t2,$t3) = (0,0,0); # timers
111+## debug / temp tools
112+$debugger{'sys'} = 1;
113+$client{'test-konvi'} = 0;
114+
115 # NOTE: redhat removed HiRes from Perl Core Modules.
116 if (eval {require Time::HiRes}){
117- Time::HiRes->import('gettimeofday','tv_interval','usleep');
118- $b_hires = 1;
119+ Time::HiRes->import('gettimeofday','tv_interval','usleep');
120+ $b_hires = 1;
121 }
122 @t0 = eval 'Time::HiRes::gettimeofday()' if $b_hires; # let's start it right away
123-## Hashes
124-my ( %alerts,%client,%colors,%debugger,%dl,%files,%rows,%system_files,%use );
125-
126-## Arrays
127-# ps_aux is full output, ps_cmd is only the last 10 columns to last
128-my (@app,@dmesg_boot,@devices_audio,@devices_graphics,@devices_network,
129-@devices_hwraid,@devices_timer,@dmi,@gpudata,@ifs,@ifs_bsd,
130-@paths,@proc_partitions,@ps_aux,@ps_cmd,@ps_gui,
131-@sysctl,@sysctl_battery,@sysctl_sensors,@sysctl_machine,@uname,@usb);
132-## Disk arrays
133-my (@dm_boot_disk,@dm_boot_optical,@glabel,@gpart,@hardware_raid,@labels,
134-@lsblk,@partitions,@raid,@sysctl_disks,@uuids);
135-my @test = (0,0,0,0,0);
136-
137-## Booleans
138-my ($b_admin,$b_arm,$b_bb_ps,$b_block_tool,$b_console_irc,
139-$b_display,$b_dmesg_boot_check,$b_dmi,$b_dmidecode_force,
140-$b_fake_bsd,$b_fake_dboot,$b_fake_dmidecode,$b_fake_pciconf,$b_fake_sysctl,
141-$b_fake_usbdevs,$b_force_display,$b_gpudata,$b_irc,
142-$b_log,$b_log_colors,$b_log_full,$b_man,$b_mem,$b_mips,
143-$b_pci,$b_pci_tool,$b_ppc,$b_proc_partitions,$b_ps_gui,
144-$b_root,$b_running_in_display,
145-$b_slot_tool,$b_soc_audio,$b_soc_gfx,$b_soc_net,$b_soc_timer,$b_sparc,
146-$b_sudo,$b_sysctl,$b_usb,$b_usb_check,$b_usb_sys,$b_usb_tool,$b_wmctrl);
147-## Disk checks
148-my ($b_dm_boot_disk,$b_dm_boot_optical,$b_glabel,$b_hardware_raid,
149-$b_label_uuid,$b_lsblk,$b_partitions,$b_raid);
150-my ($b_sysctl_disk,$b_update,$b_weather) = (1,1,1);
151+
152+## Booleans [busybox_ps not used actively]
153+my ($b_admin,$b_android,$b_arm,$b_busybox_ps,$b_display,$b_irc,
154+$b_mips,$b_ppc,$b_root,$b_running_in_display,$b_sparc);
155
156 ## System
157-my ($bsd_type,$language,$os,$pci_tool,$device_vm) = ('','','','','');
158-my ($bits_sys,$cpu_arch);
159+my ($bsd_type,$device_vm,$language,$os,$pci_tool,$wan_url) = ('','','','','','');
160+my ($bits_sys,$cpu_arch,$ppid);
161 my ($cpu_sleep,$dl_timeout,$limit,$ps_cols,$ps_count) = (0.35,4,10,0,5);
162 my $sensors_cpu_nu = 0;
163-my $weather_unit='mi';
164+my ($dl_ua,$weather_source,$weather_unit) = ('s-tools/' . $self_name . '-',100,'mi');
165
166 ## Tools
167-my ($display,$ftp_alt,$tty_session);
168-my ($display_opt,$sudo) = ('','');
169+my ($bt_tool,$display,$ftp_alt);
170+my ($display_opt,$sudoas) = ('','');
171
172 ## Output
173 my $extra = 0;# supported values: 0-3
174@@ -98,26 +121,25 @@ my $line1 = "-------------------------------------------------------------------
175 my $line2 = "======================================================================\n";
176 my $line3 = "----------------------------------------\n";
177 my ($output_file,$output_type) = ('','screen');
178-my $prefix = 0; # for the primiary row hash key prefix
179+my $prefix = 0; # for the primary row hash key prefix
180
181-# these will assign a separator to non irc states. Important! Using ':' can
182+## Initialize internal hashes
183+# these assign a separator to non irc states. Important! Using ':' can
184 # trigger stupid emoticon. Note: SEP1/SEP2 from short form not used anymore.
185 # behaviors in output on IRC, so do not use those.
186-my %sep = (
187+my %sep = (
188 's1-irc' => ':',
189 's1-console' => ':',
190 's2-irc' => '',
191 's2-console' => ':',
192 );
193-
194-my %show = ('host' => 1);
195-
196+#$show{'host'} = 1;
197 my %size = (
198 'console' => 115,
199 # Default indentation level. NOTE: actual indent is 1 greater to allow for
200 # spacing
201 'indent' => 11,
202-'indent-min' => 90,
203+'wrap-max' => 90,
204 'irc' => 100, # shorter because IRC clients have nick lists etc
205 'max' => 0,
206 'no-display' => 130,
207@@ -125,10 +147,10 @@ my %size = (
208 'term' => 80,
209 'term-lines' => 100,
210 );
211-
212-## debug / temp tools
213-$debugger{'sys'} = 1;
214-$client{'test-konvi'} = 0;
215+my %use = (
216+'update' => 1, # switched off/on with maintainer config ALLOW_UPDATE
217+'weather' => 1, # switched off/on with maintainer config ALLOW_WEATHER
218+);
219
220 ########################################################################
221 #### STARTUP
222@@ -139,28 +161,29 @@ $client{'test-konvi'} = 0;
223 #### -------------------------------------------------------------------
224
225 sub main {
226-# print Dumper \@ARGV;
227- eval $start if $b_log;
228- initialize();
229- ## use for start client debugging
230- # $debug = 10; # 3 prints timers
231- # set_debugger(); # for debugging of konvi issues
232- #my $ob_start = StartClient->new();
233- #$ob_start->get_client_data();
234- StartClient::get_client_data();
235- # print_line( Dumper \%client);
236- get_options();
237- set_debugger(); # right after so it's set
238- check_tools();
239- set_colors();
240- set_sep();
241- # print download_file('stdout','https://') . "\n";
242- generate_lines();
243- eval $end if $b_log;
244- cleanup();
245- # weechat's executor plugin forced me to do this, and rightfully so,
246- # because else the exit code from the last command is taken..
247- exit 0;
248+# print Dumper \@ARGV;
249+ eval $start if $b_log;
250+ initialize();
251+ ## Uncomment these two values for start client debugging
252+ # $debugger{'level'} = 3; # 3 prints timers / 10 prints to log file
253+ # set_debugger(); # for debugging of konvi and other start client issues
254+ ## legacy method
255+ # my $ob_start = StartClient->new();
256+ #$ob_start->get_client_data();
257+ StartClient::set();
258+ # print_line(Dumper \%client);
259+ OptionsHandler::get();
260+ set_debugger(); # right after so it's set
261+ CheckTools::set();
262+ set_colors();
263+ set_sep();
264+ # print download_file('stdout','https://') . "\n";
265+ OutputGenerator::generate();
266+ eval $end if $b_log;
267+ cleanup();
268+ # weechat's executor plugin forced me to do this, and rightfully so,
269+ # because else the exit code from the last command is taken..
270+ exit 0;
271 }
272
273 #### -------------------------------------------------------------------
274@@ -168,417 +191,515 @@ sub main {
275 #### -------------------------------------------------------------------
276
277 sub initialize {
278- set_os();
279- set_path();
280- set_user_paths();
281- set_basics();
282- system_files('set');
283- get_configs();
284- # set_downloader();
285- set_display_width('live');
286-}
287-
288-sub check_tools {
289- my ($action,$program,$message,@data,%commands,%hash);
290- if ( $b_dmi ){
291- $action = 'use';
292- if ($program = check_program('dmidecode')) {
293- @data = grabber("$program -t chassis -t baseboard -t processor 2>&1");
294- if (scalar @data < 15){
295- if ($b_root) {
296- foreach (@data){
297- if ($_ =~ /No SMBIOS/i){
298- $action = 'smbios';
299- last;
300- }
301- elsif ($_ =~ /^\/dev\/mem: Operation/i){
302- $action = 'no-data';
303- last;
304- }
305- else {
306- $action = 'unknown-error';
307- last;
308- }
309- }
310- }
311- else {
312- if (grep { $_ =~ /^\/dev\/mem: Permission/i } @data){
313- $action = 'permissions';
314- }
315- else {
316- $action = 'unknown-error';
317- }
318- }
319- }
320- }
321- else {
322- $action = 'missing';
323- }
324- %hash = (
325- 'dmidecode' => {
326- 'action' => $action,
327- 'missing' => 'Required program dmidecode not available',
328- 'permissions' => 'Unable to run dmidecode. Are you root?',
329- 'smbios' => 'No SMBIOS data for dmidecode to process',
330- 'no-data' => 'dmidecode is not allowed to read /dev/mem',
331- 'unknown-error' => 'dmidecode was unable to generate data',
332- },
333- );
334- %alerts = (%alerts, %hash);
335- }
336- # note: gnu/linux has sysctl so it may be used that for something if present
337- # there is lspci for bsds so doesn't hurt to check it
338- if ($b_pci || $b_sysctl){
339- if (!$bsd_type){
340- if ($b_pci ){
341- %hash = ('lspci' => '-n',);
342- %commands = (%commands,%hash);
343- }
344- }
345- else {
346- if ($b_pci ){
347- %hash = ('pciconf' => '-l','pcictl' => 'list', 'pcidump' => '');
348- %commands = (%commands,%hash);
349- }
350- if ($b_sysctl ){
351- # note: there is a case of kernel.osrelease but it's a linux distro
352- %hash = ('sysctl' => 'kern.osrelease',);
353- %commands = (%commands,%hash);
354- }
355- }
356- foreach ( keys %commands ){
357- $action = 'use';
358- if ($program = check_program($_)) {
359- # > 0 means error in shell
360- #my $cmd = "$program $commands{$_} >/dev/null";
361- #print "$cmd\n";
362- $pci_tool = $_ if $_ =~ /pci/;
363- $action = 'permissions' if system("$program $commands{$_} >/dev/null 2>&1");
364- }
365- else {
366- $action = 'missing';
367- }
368- %hash = (
369- $_ => {
370- 'action' => $action,
371- 'missing' => "Missing system tool: $_. Output will be incomplete",
372- 'permissions' => "Unable to run $_. Root required?",
373- },
374- );
375- %alerts = (%alerts, %hash);
376- }
377- }
378- %commands = ();
379- if ( $show{'sensor'} ){
380- %commands = ('sensors' => 'linux',);
381- }
382- # note: lsusb ships in FreeBSD ports sysutils/usbutils
383- if ( $b_usb ){
384- %hash = ('lsusb' => 'all',);
385- %commands = (%commands,%hash);
386- %hash = ('usbdevs' => 'bsd',);
387- %commands = (%commands,%hash);
388- }
389- if ($show{'ip'} || ($bsd_type && $show{'network-advanced'})){
390- %hash = (
391- 'ip' => 'linux',
392- 'ifconfig' => 'all',
393- );
394- %commands = (%commands,%hash);
395- }
396- # can't check permissions since we need to know the partition
397- if ($b_block_tool){
398- %hash = (
399- 'blockdev' => 'linux',
400- 'lsblk' => 'linux',
401- );
402- %commands = (%commands,%hash);
403- }
404- foreach ( keys %commands ){
405- $action = 'use';
406- $message = 'Present and working';
407- if ( ($commands{$_} eq 'linux' && $os ne 'linux' ) || ($commands{$_} eq 'bsd' && $os eq 'linux' ) ){
408- $message = "No " . ucfirst($os) . " support. Is a comparable $_ tool available?";
409- $action = 'platform';
410- }
411- elsif (!check_program($_)){
412- $message = "Required tool $_ not installed. Check --recommends";
413- $action = 'missing';
414- }
415- %hash = (
416- $_ => {
417- 'action' => $action,
418- 'missing' => $message,
419- 'platform' => $message,
420- },
421- );
422- %alerts = (%alerts, %hash);
423- }
424- # print Dumper \%alerts;
425- # only use sudo if not root, -n option requires sudo -V 1.7 or greater.
426- # for some reason sudo -n with < 1.7 in Perl does not print to stderr
427- # sudo will just error out which is the safest course here for now,
428- # otherwise that interactive sudo password thing is too annoying
429- # important: -n makes it non interactive, no prompt for password
430- if (!$b_root && $b_sudo && (my $path = main::check_program('sudo') )) {
431- my @data = program_values('sudo');
432- my $version = program_version($path,$data[0],$data[1],$data[2],$data[5]);
433- $version =~ s/^([0-9]+\.[0-9]+).*/$1/;
434- $sudo = "$path -n " if $version >= 1.7;
435- }
436- set_fake_tools() if $b_fake_bsd;
437+ set_os();
438+ set_path();
439+ set_user_paths();
440+ set_basics();
441+ set_system_files();
442+ Configs::set();
443+ # set_downloader();
444+ set_display_width('live');
445+}
446+
447+## CheckTools
448+{
449+package CheckTools;
450+my (%commands);
451+sub set {
452+ eval $start if $b_log;
453+ set_commands();
454+ my ($action,$program,$message,@data);
455+ foreach my $test (keys %commands){
456+ ($action,$program) = ('use','');
457+ $message = main::row_defaults('tool-present');
458+ if ($commands{$test}->[1] && (
459+ ($commands{$test}->[1] eq 'linux' && $os ne 'linux') ||
460+ ($commands{$test}->[1] eq 'bsd' && $os eq 'linux'))){
461+ $action = 'platform';
462+ }
463+ elsif ($program = main::check_program($test)){
464+ # > 0 means error in shell
465+ # my $cmd = "$program $commands{$test} >/dev/null";
466+ # print "$cmd\n";
467+ $pci_tool = $test if $test =~ /pci/;
468+ if ($commands{$test}->[0] eq 'exec-sys'){
469+ $action = 'permissions' if system("$program $commands{$test}->[2] >/dev/null 2>&1");
470+ }
471+ elsif ($commands{$test}->[0] eq 'exec-string'){
472+ @data = main::grabber("$program $commands{$test}->[2] 2>&1");
473+ # dmidecode errors are so specific it gets its own section
474+ # also sets custom dmidecode error messages
475+ if ($test eq 'dmidecode'){
476+ $action = set_dmidecode(\@data) if scalar @data < 15;
477+ }
478+ elsif (grep { $_ =~ /$commands{$test}->[3]/i } @data){
479+ $action = 'permissions';
480+ }
481+ }
482+ }
483+ else {
484+ $action = 'missing';
485+ }
486+ $alerts{$test}->{'action'} = $action;
487+ $alerts{$test}->{'path'} = $program;
488+ if ($action eq 'missing'){
489+ $alerts{$test}->{'message'} = main::row_defaults('tool-missing-recommends',"$test");
490+ }
491+ elsif ($action eq 'permissions'){
492+ $alerts{$test}->{'message'} = main::row_defaults('tool-permissions',"$test");
493+ }
494+ elsif ($action eq 'platform'){
495+ $alerts{$test}->{'message'} = main::row_defaults('tool-missing-os', $uname[0] . " $test");
496+ }
497+ }
498+ print Data::Dumper::Dumper \%alerts if $dbg[25];
499+ set_fake_bsd_tools() if $fake{'bsd'};
500+ set_forced_tools();
501+ eval $end if $b_log;
502+}
503+sub set_dmidecode {
504+ my ($data) = @_;
505+ my $action = 'use';
506+ if ($b_root){
507+ foreach (@$data){
508+ # don't need first line or scanning /dev/mem lines
509+ if (/^(# dmi|Scanning)/){
510+ next;
511+ }
512+ elsif ($_ =~ /No SMBIOS/i){
513+ $action = 'smbios';
514+ last;
515+ }
516+ elsif ($_ =~ /^\/dev\/mem: Operation/i){
517+ $action = 'no-data';
518+ last;
519+ }
520+ else {
521+ $action = 'unknown-error';
522+ last;
523+ }
524+ }
525+ }
526+ else {
527+ if (grep { $_ =~ /^\/dev\/mem: Permission/i } @$data){
528+ $action = 'permissions';
529+ }
530+ else {
531+ $action = 'unknown-error';
532+ }
533+ }
534+ if ($action ne 'use' && $action ne 'permissions'){
535+ if ($action eq 'smbios'){
536+ $alerts{'dmidecode'}->{'message'} = main::row_defaults('dmidecode-smbios');
537+ }
538+ elsif ($action eq 'no-data'){
539+ $alerts{'dmidecode'}->{'message'} = main::row_defaults('dmidecode-dev-mem');
540+ }
541+ elsif ($action eq 'unknown-error'){
542+ $alerts{'dmidecode'}->{'message'} = main::row_defaults('tool-unknown-error','dmidecode');
543+ }
544+ }
545+ return $action;
546+}
547+sub set_commands {
548+ # note: gnu/linux has sysctl so it may be used that for something if present
549+ # there is lspci for bsds so doesn't hurt to check it
550+ if (!$bsd_type){
551+ if ($use{'pci'}){
552+ $commands{'lspci'} = ['exec-sys','','-n'];
553+ }
554+ if ($use{'logical'}){
555+ $commands{'lvs'} = ['exec-sys','',''];
556+ }
557+ }
558+ else {
559+ if ($use{'pci'}){
560+ $commands{'pciconf'} = ['exec-sys','','-l'];
561+ $commands{'pcictl'} = ['exec-sys','',' pci0 list'];
562+ $commands{'pcidump'} = ['exec-sys','',''];
563+ }
564+ if ($use{'sysctl'}){
565+ # note: there is a case of kernel.osrelease but it's a linux distro
566+ $commands{'sysctl'} = ['exec-sys','','kern.osrelease'];
567+ }
568+ if ($use{'bsd-partition'}){
569+ $commands{'bioctl'} = ['missing','',''];
570+ $commands{'disklabel'} = ['missing','',''];
571+ $commands{'fdisk'} = ['missing','',''];
572+ $commands{'gpart'} = ['missing','',''];
573+ }
574+ }
575+ if ($use{'dmidecode'}){
576+ $commands{'dmidecode'} = ['exec-string','','-t chassis -t baseboard -t processor',''];
577+ }
578+ if ($use{'usb'}){
579+ # note: lsusb ships in FreeBSD ports sysutils/usbutils
580+ $commands{'lsusb'} = ['missing','','',''];
581+ # we want these set for various null bsd data tests
582+ $commands{'usbconfig'} = ['exec-string','bsd','list','permissions'];
583+ $commands{'usbdevs'} = ['missing','bsd','',''];
584+ }
585+ if ($show{'bluetooth'}){
586+ $commands{'bluetoothctl'} = ['missing','linux','',''];
587+ # bt-adapter hangs when bluetooth service is disabled
588+ $commands{'bt-adapter'} = ['missing','linux','',''];
589+ $commands{'hciconfig'} = ['missing','linux','',''];
590+ }
591+ if ($show{'sensor'}){
592+ $commands{'sensors'} = ['missing','linux','',''];
593+ }
594+ if ($show{'ip'} || ($bsd_type && $show{'network-advanced'})){
595+ $commands{'ip'} = ['missing','linux','',''];
596+ $commands{'ifconfig'} = ['missing','','',''];
597+ }
598+ # can't check permissions since we need to know the partition/disc
599+ if ($use{'block-tool'}){
600+ $commands{'blockdev'} = ['missing','linux','',''];
601+ $commands{'lsblk'} = ['missing','linux','',''];
602+ }
603+ if ($use{'btrfs'}){
604+ $commands{'btrfs'} = ['missing','linux','',''];
605+ }
606+ if ($use{'mdadm'}){
607+ $commands{'mdadm'} = ['missing','linux','',''];
608+ }
609+ if ($use{'smartctl'}){
610+ $commands{'smartctl'} = ['missing','','',''];
611+ }
612+ if ($show{'unmounted'}){
613+ $commands{'disklabel'} = ['missing','bsd','xx'];
614+ }
615+}
616+sub set_forced_tools {
617+ if ($bt_tool){
618+ if ($bt_tool ne 'bluetootctl' && $alerts{'bluetoothctl'}->{'action'} eq 'use'){
619+ $alerts{'bluetoothctl'}->{'action'} = 'missing';
620+ }
621+ if ($bt_tool ne 'bt-adapter' && $alerts{'bt-adapter'}->{'action'} eq 'use'){
622+ $alerts{'bt-adapter'}->{'action'} = 'missing';
623+ }
624+ if ($bt_tool ne 'hciconfig' && $alerts{'hciconfig'}->{'action'} eq 'use'){
625+ $alerts{'hciconfig'}->{'action'} = 'missing';
626+ }
627+ }
628+}
629+# only for dev/debugging BSD
630+sub set_fake_bsd_tools {
631+ $system_files{'dmesg-boot'} = '/var/run/dmesg.boot' if $fake{'dboot'};
632+ $alerts{'sysctl'}->{'action'} = 'use' if $fake{'sysctl'};
633+ if ($fake{'pciconf'} || $fake{'pcictl'} || $fake{'pcidump'}){
634+ $alerts{'pciconf'}->{'action'} = 'use' if $fake{'pciconf'};
635+ $alerts{'pcictl'}->{'action'} = 'use' if $fake{'pcictl'};
636+ $alerts{'pcidump'}->{'action'} = 'use' if $fake{'pcidump'};
637+ $alerts{'lspci'} = {
638+ 'action' => 'missing',
639+ 'message' => 'Required program lspci not available',
640+ };
641+ }
642+ if ($fake{'usbconfig'} || $fake{'usbdevs'}){
643+ $alerts{'usbconfig'}->{'action'} = 'use' if $fake{'usbconfig'};
644+ $alerts{'usbdevs'}->{'action'} = 'use' if $fake{'usbdevs'};
645+ $alerts{'lsusb'} = {
646+ 'action' => 'missing',
647+ 'message' => 'Required program lsusb not available',
648+ };
649+ }
650+ if ($fake{'disklabel'}){
651+ $alerts{'disklabel'}->{'action'} = 'use';
652+ }
653+}
654 }
655
656 # args: 1 - desktop/app command for --version; 2 - search string;
657 # 3 - space print number; 4 - [optional] version arg: -v, version, etc
658 # 5 - [optional] exit first find 0/1; 6 - [optional] 0/1 stderr output
659 sub set_basics {
660- ### LOCALIZATION - DO NOT CHANGE! ###
661- # set to default LANG to avoid locales errors with , or .
662- # Make sure every program speaks English.
663- $ENV{'LANG'}='C';
664- $ENV{'LC_ALL'}='C';
665- # remember, perl uses the opposite t/f return as shell!!!
666- # some versions of busybox do not have tty, like openwrt
667- $b_irc = ( check_program('tty') && system('tty >/dev/null') ) ? 1 : 0;
668- # print "birc: $b_irc\n";
669- $b_display = ( $ENV{'DISPLAY'} ) ? 1 : 0;
670- $b_root = ( $ENV{'HOME'} eq '/root' ) ? 1 : 0;
671- $dl{'dl'} = 'curl';
672- $dl{'curl'} = 1;
673- $dl{'tiny'} = 1; # note: two modules needed, tested for in set_downloader
674- $dl{'wget'} = 1;
675- $dl{'fetch'} = 1;
676- $client{'console-irc'} = 0;
677- $client{'dcop'} = (check_program('dcop')) ? 1 : 0;
678- $client{'qdbus'} = (check_program('qdbus')) ? 1 : 0;
679- $client{'konvi'} = 0;
680- $client{'name'} = '';
681- $client{'name-print'} = '';
682- $client{'su-start'} = ''; # shows sudo/su
683- $client{'version'} = '';
684- $colors{'default'} = 2;
685- $show{'partition-sort'} = 'id'; # sort order for partitions
686+ ### LOCALIZATION - DO NOT CHANGE! ###
687+ # set to default LANG to avoid locales errors with , or .
688+ # Make sure every program speaks English.
689+ $ENV{'LANG'}='C';
690+ $ENV{'LC_ALL'}='C';
691+ # remember, perl uses the opposite t/f return as shell!!!
692+ # some versions of busybox do not have tty, like openwrt
693+ $b_irc = (check_program('tty') && system('tty >/dev/null')) ? 1 : 0;
694+ # print "birc: $b_irc\n";
695+ $b_display = ($ENV{'DISPLAY'}) ? 1 : 0;
696+ $b_root = $< == 0; # root UID 0, all others > 0
697+ $dl{'dl'} = 'curl';
698+ $dl{'curl'} = 1;
699+ $dl{'tiny'} = 1; # note: two modules needed, tested for in set_downloader
700+ $dl{'wget'} = 1;
701+ $dl{'fetch'} = 1;
702+ $client{'console-irc'} = 0;
703+ $client{'dcop'} = (check_program('dcop')) ? 1 : 0;
704+ $client{'qdbus'} = (check_program('qdbus')) ? 1 : 0;
705+ $client{'konvi'} = 0;
706+ $client{'name'} = '';
707+ $client{'name-print'} = '';
708+ $client{'su-start'} = ''; # shows sudo/su
709+ $client{'version'} = '';
710+ $colors{'default'} = 2;
711+ $show{'partition-sort'} = 'id'; # sort order for partitions
712+ @raw_logical = (0,0,0);
713+ $ppid = getppid();
714 }
715
716 # args: $1 - default OR override default cols max integer count. $_[0]
717 # is the display width override.
718 sub set_display_width {
719- my ($width) = @_;
720- if ( $width eq 'live' ){
721- ## sometimes tput will trigger an error (mageia) if irc client
722- if ( ! $b_irc ){
723- if ( check_program('tput') ) {
724- # trips error if use qx()...
725- chomp($size{'term'}=qx{tput cols});
726- chomp($size{'term-lines'}=qx{tput lines});
727- $size{'term-cols'} = $size{'term'};
728- }
729- # print "tc: $size{'term'} cmc: $size{'console'}\n";
730- # double check, just in case it's missing functionality or whatever
731- if ( $size{'term'} == 0 || $size{'term'} !~ /\d/ ){
732- $size{'term'}=80;
733- # we'll be using this for terminal dimensions later so don't set default.
734- # $size{'term-lines'}=100;
735- }
736- }
737- # this lets you set different size for in or out of display server
738- if ( ! $b_running_in_display && $size{'no-display'} ){
739- $size{'console'}=$size{'no-display'};
740- }
741- # term_cols is set in top globals, using tput cols
742- # print "tc: $size{'term'} cmc: $size{'console'}\n";
743- if ( $size{'term'} < $size{'console'} ){
744- $size{'console'}=$size{'term'};
745- }
746- # adjust, some terminals will wrap if output cols == term cols
747- $size{'console'}=( $size{'console'} - 2 );
748- # echo cmc: $size{'console'}
749- # comes after source for user set stuff
750- if ( ! $b_irc ){
751- $size{'max'}=$size{'console'};
752- }
753- else {
754- $size{'max'}=$size{'irc'};
755- }
756- }
757- else {
758- $size{'max'}=$width;
759- }
760- # print "tc: $size{'term'} cmc: $size{'console'} cm: $size{'max'}\n";
761-}
762-
763-# only for dev/debugging BSD
764-sub set_fake_tools {
765- $system_files{'dmesg-boot'} = '/var/run/dmesg.boot' if $b_fake_dboot;
766- $alerts{'pciconf'} = ({'action' => 'use'}) if $b_fake_pciconf;
767- $alerts{'sysctl'} = ({'action' => 'use'}) if $b_fake_sysctl;
768- if ($b_fake_usbdevs ){
769- $alerts{'usbdevs'} = ({'action' => 'use'});
770- $alerts{'lsusb'} = ({
771- 'action' => 'missing',
772- 'missing' => 'Required program lsusb not available',
773- });
774- }
775+ my ($width) = @_;
776+ if ($width eq 'live'){
777+ ## sometimes tput will trigger an error (mageia) if irc client
778+ if (!$b_irc){
779+ if (my $program = check_program('tput')){
780+ # Arch urxvt: 'tput: unknown terminal "rxvt-unicode-256color"'
781+ # trips error if use qx(); in FreeBSD, if you use 2>/dev/null
782+ # it makes default value 80x24, who knows why?
783+ chomp($size{'term'} = qx{$program cols});
784+ chomp($size{'term-lines'} = qx{$program lines});
785+ $size{'term-cols'} = $size{'term'};
786+ }
787+ # print "tc: $size{'term'} cmc: $size{'console'}\n";
788+ # double check, just in case it's missing functionality or whatever
789+ if (!is_int($size{'term'} || $size{'term'} == 0)){
790+ $size{'term'}=80;
791+ # we'll be using this for terminal dimensions later so don't set default.
792+ # $size{'term-lines'}=100;
793+ }
794+ }
795+ # this lets you set different size for in or out of display server
796+ if (!$b_running_in_display && $size{'no-display'}){
797+ $size{'console'} = $size{'no-display'};
798+ }
799+ # term_cols is set in top globals, using tput cols
800+ # print "tc: $size{'term'} cmc: $size{'console'}\n";
801+ if ($size{'term'} < $size{'console'}){
802+ $size{'console'} = $size{'term'};
803+ }
804+ # adjust, some terminals will wrap if output cols == term cols
805+ $size{'console'} = ($size{'console'} - 2);
806+ # echo cmc: $size{'console'}
807+ # comes after source for user set stuff
808+ if (!$b_irc){
809+ $size{'max'} = $size{'console'};
810+ }
811+ else {
812+ $size{'max'} = $size{'irc'};
813+ }
814+ }
815+ else {
816+ $size{'max'} = $width;
817+ }
818+ # print "tc: $size{'term'} cmc: $size{'console'} cm: $size{'max'}\n";
819 }
820
821 # NOTE: most tests internally are against !$bsd_type
822 sub set_os {
823- @uname = uname();
824- $os = lc($uname[0]);
825- $cpu_arch = lc($uname[-1]);
826- if ($cpu_arch =~ /arm|aarch/){$b_arm = 1}
827- elsif ($cpu_arch =~ /mips/) {$b_mips = 1}
828- elsif ($cpu_arch =~ /power|ppc/) {$b_ppc = 1}
829- elsif ($cpu_arch =~ /sparc/) {$b_sparc = 1}
830- # aarch32 mips32 intel/amd handled in cpu
831- if ($cpu_arch =~ /(armv[1-7]|32|sparc_v9)/){
832- $bits_sys = 32;
833- }
834- elsif ($cpu_arch =~ /(alpha|64)/){
835- $bits_sys = 64;
836- }
837- if ( $os =~ /(aix|bsd|cosix|dragonfly|darwin|hp-?ux|indiana|irix|sunos|solaris|ultrix|unix)/ ){
838- if ( $os =~ /openbsd/ ){
839- $os = 'openbsd';
840- }
841- elsif ($os =~ /darwin/){
842- $os = 'darwin';
843- }
844- if ($os =~ /kfreebsd/){
845- $bsd_type = 'debian-bsd';
846- }
847- else {
848- $bsd_type = $os;
849- }
850- }
851-}
852-
853-# This data is hard set top of program but due to a specific project's
854-# foolish idea that ignoring the FSH totally is somehow a positive step
855-# forwards for free software, we also have to padd the results with PATH.
856+ @uname = uname();
857+ $os = lc($uname[0]);
858+ $cpu_arch = lc($uname[-1]);
859+ if ($cpu_arch =~ /arm|aarch/){$b_arm = 1;}
860+ elsif ($cpu_arch =~ /mips/){$b_mips = 1}
861+ elsif ($cpu_arch =~ /power|ppc/){$b_ppc = 1}
862+ elsif ($cpu_arch =~ /sparc/){$b_sparc = 1}
863+ # aarch32 mips32 intel/amd handled in cpu
864+ if ($cpu_arch =~ /(armv[1-7]|32|sparc_v9)/){
865+ $bits_sys = 32;
866+ }
867+ elsif ($cpu_arch =~ /(alpha|64|e2k)/){
868+ $bits_sys = 64;
869+ }
870+ $b_android = 1 if -e '/system/build.prop';
871+ if ($os =~ /(aix|bsd|cosix|dragonfly|darwin|hp-?ux|indiana|irix|sunos|solaris|ultrix|unix)/){
872+ if ($os =~ /openbsd/){
873+ $os = 'openbsd';
874+ }
875+ elsif ($os =~ /darwin/){
876+ $os = 'darwin';
877+ }
878+ if ($os =~ /kfreebsd/){
879+ $bsd_type = 'debian-bsd';
880+ }
881+ else {
882+ $bsd_type = $os;
883+ }
884+ }
885+}
886+
887+# Sometimes users will have more PATHs local to their setup, so we want those
888+# too.
889 sub set_path {
890- # Extra path variable to make execute failures less likely, merged below
891- my (@path);
892- # NOTE: recent Xorg's show error if you try /usr/bin/Xorg -version but work
893- # if you use the /usr/lib/xorg-server/Xorg path.
894- @paths = qw(/sbin /bin /usr/sbin /usr/bin /usr/local/sbin /usr/local/bin);
895- @path = split /:/, $ENV{'PATH'} if $ENV{'PATH'};
896- # print "paths: @paths\nPATH: $ENV{'PATH'}\n";
897- # Create a difference of $PATH and $extra_paths and add that to $PATH:
898- foreach my $id (@path) {
899- if ( !(grep { /^$id$/ } @paths) && $id !~ /(game)/ ){
900- push @paths, $id;
901- }
902- }
903- # print "paths: @paths\n";
904+ # Extra path variable to make execute failures less likely, merged below
905+ my (@path);
906+ # NOTE: recent Xorg's show error if you try /usr/bin/Xorg -version but work
907+ # if you use the /usr/lib/xorg-server/Xorg path.
908+ @paths = qw(/sbin /bin /usr/sbin /usr/bin /usr/local/sbin /usr/local/bin);
909+ @path = split(':', $ENV{'PATH'}) if $ENV{'PATH'};
910+ # print "paths: @paths\nPATH: $ENV{'PATH'}\n";
911+ # Create a difference of $PATH and $extra_paths and add that to $PATH:
912+ foreach my $id (@path){
913+ if (!(grep { /^$id$/ } @paths) && $id !~ /(game)/){
914+ push(@paths, $id);
915+ }
916+ }
917+ # print "paths: @paths\n";
918 }
919
920 sub set_sep {
921- if ( $b_irc ){
922- # too hard to read if no colors, so force that for users on irc
923- if ($colors{'scheme'} == 0 ){
924- $sep{'s1'} = $sep{'s1-console'};
925- $sep{'s2'} = $sep{'s2-console'};
926- }
927- else {
928- $sep{'s1'} = $sep{'s1-irc'};
929- $sep{'s2'} = $sep{'s2-irc'};
930- }
931- }
932- else {
933- $sep{'s1'} = $sep{'s1-console'};
934- $sep{'s2'} = $sep{'s2-console'};
935- }
936+ if ($b_irc){
937+ # too hard to read if no colors, so force that for users on irc
938+ if ($colors{'scheme'} == 0){
939+ $sep{'s1'} = $sep{'s1-console'};
940+ $sep{'s2'} = $sep{'s2-console'};
941+ }
942+ else {
943+ $sep{'s1'} = $sep{'s1-irc'};
944+ $sep{'s2'} = $sep{'s2-irc'};
945+ }
946+ }
947+ else {
948+ $sep{'s1'} = $sep{'s1-console'};
949+ $sep{'s2'} = $sep{'s2-console'};
950+ }
951+}
952+
953+# Important: -n makes it non interactive, no prompt for password
954+# only use doas/sudo if not root, -n option requires sudo -V 1.7 or greater.
955+# for some reason sudo -n with < 1.7 in Perl does not print to stderr
956+# sudo will just error out which is the safest course here for now,
957+# otherwise that interactive sudo password thing is too annoying
958+sub set_sudo {
959+ if (!$b_root){
960+ my ($path);
961+ if (!$force{'no-doas'} && ($path = check_program('doas'))){
962+ $sudoas = "$path -n ";
963+ }
964+ elsif (!$force{'no-sudo'} && ($path = check_program('sudo'))){
965+ my @data = program_data('sudo');
966+ $data[1] =~ s/^([0-9]+\.[0-9]+).*/$1/;
967+ # print "sudo v: $data[1]\n";
968+ $sudoas = "$path -n " if is_numeric($data[1]) && $data[1] >= 1.7;
969+ }
970+ }
971+}
972+
973+sub set_system_files {
974+ my %files = (
975+ 'asound-cards' => '/proc/asound/cards',
976+ 'asound-modules' => '/proc/asound/modules',
977+ 'asound-version' => '/proc/asound/version',
978+ 'dmesg-boot' => '/var/run/dmesg.boot',
979+ 'proc-cmdline' => '/proc/cmdline',
980+ 'proc-cpuinfo' => '/proc/cpuinfo',
981+ 'proc-mdstat' => '/proc/mdstat',
982+ 'proc-meminfo' => '/proc/meminfo',
983+ 'proc-modules' => '/proc/modules', # not used
984+ 'proc-mounts' => '/proc/mounts',# not used
985+ 'proc-partitions' => '/proc/partitions',
986+ 'proc-scsi' => '/proc/scsi/scsi',
987+ 'proc-version' => '/proc/version',
988+ # note: 'xorg-log' is set in set_xorg_log() only if -G is triggered
989+ );
990+ foreach (keys %files){
991+ $system_files{$_} = (-e $files{$_}) ? $files{$_} : '';
992+ }
993 }
994
995 sub set_user_paths {
996- my ( $b_conf, $b_data );
997- # this needs to be set here because various options call the parent
998- # initialize function directly.
999- $self_path = $0;
1000- $self_path =~ s/[^\/]+$//;
1001- # print "0: $0 sp: $self_path\n";
1002-
1003- if ( defined $ENV{'XDG_CONFIG_HOME'} && $ENV{'XDG_CONFIG_HOME'} ){
1004- $user_config_dir=$ENV{'XDG_CONFIG_HOME'};
1005- $b_conf=1;
1006- }
1007- elsif ( -d "$ENV{'HOME'}/.config" ){
1008- $user_config_dir="$ENV{'HOME'}/.config";
1009- $b_conf=1;
1010- }
1011- else {
1012- $user_config_dir="$ENV{'HOME'}/.$self_name";
1013- }
1014- if ( defined $ENV{'XDG_DATA_HOME'} && $ENV{'XDG_DATA_HOME'} ){
1015- $user_data_dir="$ENV{'XDG_DATA_HOME'}/$self_name";
1016- $b_data=1;
1017- }
1018- elsif ( -d "$ENV{'HOME'}/.local/share" ){
1019- $user_data_dir="$ENV{'HOME'}/.local/share/$self_name";
1020- $b_data=1;
1021- }
1022- else {
1023- $user_data_dir="$ENV{'HOME'}/.$self_name";
1024- }
1025- # note, this used to be created/checked in specific instance, but we'll just do it
1026- # universally so it's done at script start.
1027- if ( ! -d $user_data_dir ){
1028- mkdir $user_data_dir;
1029- # system "echo", "Made: $user_data_dir";
1030- }
1031- if ( $b_conf && -f "$ENV{'HOME'}/.$self_name/$self_name.conf" ){
1032- #system 'mv', "-f $ENV{'HOME'}/.$self_name/$self_name.conf", $user_config_dir;
1033- # print "WOULD: Moved $self_name.conf from $ENV{'HOME'}/.$self_name to $user_config_dir\n";
1034- }
1035- if ( $b_data && -d "$ENV{'HOME'}/.$self_name" ){
1036- #system 'mv', '-f', "$ENV{'HOME'}/.$self_name/*", $user_data_dir;
1037- #system 'rm', '-Rf', "$ENV{'HOME'}/.$self_name";
1038- # print "WOULD: Moved data dir $ENV{'HOME'}/.$self_name to $user_data_dir\n";
1039- }
1040- $log_file="$user_data_dir/$self_name.log";
1041- #system 'echo', "$ENV{'HOME'}/.$self_name/* $user_data_dir";
1042- # print "scd: $user_config_dir sdd: $user_data_dir \n";
1043-}
1044-
1045-# args: 1: set|hash key to return either null or path
1046-sub system_files {
1047- my ($file) = @_;
1048- if ( $file eq 'set'){
1049- %files = (
1050- 'asound-cards' => '/proc/asound/cards',
1051- 'asound-modules' => '/proc/asound/modules',
1052- 'asound-version' => '/proc/asound/version',
1053- 'cpuinfo' => '/proc/cpuinfo',
1054- 'dmesg-boot' => '/var/run/dmesg.boot',
1055- 'lsb-release' => '/etc/lsb-release',
1056- 'mdstat' => '/proc/mdstat',
1057- 'meminfo' => '/proc/meminfo',
1058- 'modules' => '/proc/modules',
1059- 'mounts' => '/proc/mounts',
1060- 'os-release' => '/etc/os-release',
1061- 'partitions' => '/proc/partitions',
1062- 'scsi' => '/proc/scsi/scsi',
1063- 'version' => '/proc/version',
1064- 'xorg-log' => '/var/log/Xorg.0.log'
1065- );
1066- foreach ( keys %files ){
1067- $system_files{$_} = ( -e $files{$_} ) ? $files{$_} : '';
1068- }
1069- if ( ! $system_files{'xorg-log'} && check_program('xset') ){
1070- my $data = qx(xset q 2>/dev/null);
1071- foreach ( split /\n/, $data){
1072- if ($_ =~ /Log file/i){
1073- $system_files{'xorg-log'} = get_piece($_,3);
1074- last;
1075- }
1076- }
1077- }
1078- }
1079- else {
1080- return $system_files{$file};
1081- }
1082+ my ($b_conf,$b_data);
1083+ # this needs to be set here because various options call the parent
1084+ # initialize function directly.
1085+ $self_path = $0;
1086+ $self_path =~ s/[^\/]+$//;
1087+ # print "0: $0 sp: $self_path\n";
1088+ if (defined $ENV{'XDG_CONFIG_HOME'} && $ENV{'XDG_CONFIG_HOME'}){
1089+ $user_config_dir=$ENV{'XDG_CONFIG_HOME'};
1090+ $b_conf=1;
1091+ }
1092+ elsif (-d "$ENV{'HOME'}/.config"){
1093+ $user_config_dir="$ENV{'HOME'}/.config";
1094+ $b_conf=1;
1095+ }
1096+ else {
1097+ $user_config_dir="$ENV{'HOME'}/.$self_name";
1098+ }
1099+ if (defined $ENV{'XDG_DATA_HOME'} && $ENV{'XDG_DATA_HOME'}){
1100+ $user_data_dir="$ENV{'XDG_DATA_HOME'}/$self_name";
1101+ $b_data=1;
1102+ }
1103+ elsif (-d "$ENV{'HOME'}/.local/share"){
1104+ $user_data_dir="$ENV{'HOME'}/.local/share/$self_name";
1105+ $b_data=1;
1106+ }
1107+ else {
1108+ $user_data_dir="$ENV{'HOME'}/.$self_name";
1109+ }
1110+ # note, this used to be created/checked in specific instance, but we'll just
1111+ # do it universally so it's done at script start.
1112+ if (! -d $user_data_dir){
1113+ mkdir $user_data_dir;
1114+ # system "echo", "Made: $user_data_dir";
1115+ }
1116+ if ($b_conf && -f "$ENV{'HOME'}/.$self_name/$self_name.conf"){
1117+ # system 'mv', "-f $ENV{'HOME'}/.$self_name/$self_name.conf", $user_config_dir;
1118+ # print "WOULD: Moved $self_name.conf from $ENV{'HOME'}/.$self_name to $user_config_dir\n";
1119+ }
1120+ if ($b_data && -d "$ENV{'HOME'}/.$self_name"){
1121+ # system 'mv', '-f', "$ENV{'HOME'}/.$self_name/*", $user_data_dir;
1122+ # system 'rm', '-Rf', "$ENV{'HOME'}/.$self_name";
1123+ # print "WOULD: Moved data dir $ENV{'HOME'}/.$self_name to $user_data_dir\n";
1124+ }
1125+ $log_file="$user_data_dir/$self_name.log";
1126+ # system 'echo', "$ENV{'HOME'}/.$self_name/* $user_data_dir";
1127+ # print "scd: $user_config_dir sdd: $user_data_dir \n";
1128+}
1129+
1130+sub set_xorg_log {
1131+ eval $start if $b_log;
1132+ my (@temp,@x_logs);
1133+ my ($file_holder,$time_holder,$x_mtime) = ('',0,0);
1134+ # NOTE: other variations may be /var/run/gdm3/... but not confirmed
1135+ # worry about we are just going to get all the Xorg logs we can find,
1136+ # and not which is 'right'.
1137+ @temp = globber('/var/log/Xorg.*.log');
1138+ push(@x_logs, @temp) if @temp;
1139+ @temp = globber('/var/lib/gdm/.local/share/xorg/Xorg.*.log');
1140+ push(@x_logs, @temp) if @temp;
1141+ @temp = globber($ENV{'HOME'} . '/.local/share/xorg/Xorg.*.log',);
1142+ push(@x_logs, @temp) if @temp;
1143+ # root will not have a /root/.local/share/xorg directory so need to use a
1144+ # user one if we can find one.
1145+ if ($b_root){
1146+ @temp = globber('/home/*/.local/share/xorg/Xorg.*.log');
1147+ push(@x_logs, @temp) if @temp;
1148+ }
1149+ foreach (@x_logs){
1150+ if (-r $_){
1151+ my $src_info = File::stat::stat("$_");
1152+ # print "$_\n";
1153+ if ($src_info){
1154+ $x_mtime = $src_info->mtime;
1155+ # print $_ . ": $x_time" . "\n";
1156+ if ($x_mtime > $time_holder){
1157+ $time_holder = $x_mtime;
1158+ $file_holder = $_;
1159+ }
1160+ }
1161+ }
1162+ }
1163+ if (!$file_holder && check_program('xset')){
1164+ my $data = qx(xset q 2>/dev/null);
1165+ foreach (split('\n', $data)){
1166+ if ($_ =~ /Log file/i){
1167+ $file_holder = get_piece($_,3);
1168+ last;
1169+ }
1170+ }
1171+ }
1172+ print "Xorg log file: $file_holder\nLast modified: $time_holder\n" if $dbg[14];
1173+ log_data('data',"Xorg log file: $file_holder") if $b_log;
1174+ $system_files{'xorg-log'} = $file_holder;
1175+ eval $end if $b_log;
1176 }
1177
1178 ########################################################################
1179@@ -591,425 +712,420 @@ sub system_files {
1180
1181 ## arg: 1 - the type of action, either integer, count, or full
1182 sub get_color_scheme {
1183- my ($type) = @_;
1184- eval $start if $b_log;
1185- my @color_schemes = (
1186- [qw(EMPTY EMPTY EMPTY )],
1187- [qw(NORMAL NORMAL NORMAL )],
1188- # for dark OR light backgrounds
1189- [qw(BLUE NORMAL NORMAL)],
1190- [qw(BLUE RED NORMAL )],
1191- [qw(CYAN BLUE NORMAL )],
1192- [qw(DCYAN NORMAL NORMAL)],
1193- [qw(DCYAN BLUE NORMAL )],
1194- [qw(DGREEN NORMAL NORMAL )],
1195- [qw(DYELLOW NORMAL NORMAL )],
1196- [qw(GREEN DGREEN NORMAL )],
1197- [qw(GREEN NORMAL NORMAL )],
1198- [qw(MAGENTA NORMAL NORMAL)],
1199- [qw(RED NORMAL NORMAL)],
1200- # for light backgrounds
1201- [qw(BLACK DGREY NORMAL)],
1202- [qw(DBLUE DGREY NORMAL )],
1203- [qw(DBLUE DMAGENTA NORMAL)],
1204- [qw(DBLUE DRED NORMAL )],
1205- [qw(DBLUE BLACK NORMAL)],
1206- [qw(DGREEN DYELLOW NORMAL )],
1207- [qw(DYELLOW BLACK NORMAL)],
1208- [qw(DMAGENTA BLACK NORMAL)],
1209- [qw(DCYAN DBLUE NORMAL)],
1210- # for dark backgrounds
1211- [qw(WHITE GREY NORMAL)],
1212- [qw(GREY WHITE NORMAL)],
1213- [qw(CYAN GREY NORMAL )],
1214- [qw(GREEN WHITE NORMAL )],
1215- [qw(GREEN YELLOW NORMAL )],
1216- [qw(YELLOW WHITE NORMAL )],
1217- [qw(MAGENTA CYAN NORMAL )],
1218- [qw(MAGENTA YELLOW NORMAL)],
1219- [qw(RED CYAN NORMAL)],
1220- [qw(RED WHITE NORMAL )],
1221- [qw(BLUE WHITE NORMAL)],
1222- # miscellaneous
1223- [qw(RED BLUE NORMAL )],
1224- [qw(RED DBLUE NORMAL)],
1225- [qw(BLACK BLUE NORMAL)],
1226- [qw(BLACK DBLUE NORMAL)],
1227- [qw(NORMAL BLUE NORMAL)],
1228- [qw(BLUE MAGENTA NORMAL)],
1229- [qw(DBLUE MAGENTA NORMAL)],
1230- [qw(BLACK MAGENTA NORMAL)],
1231- [qw(MAGENTA BLUE NORMAL)],
1232- [qw(MAGENTA DBLUE NORMAL)],
1233- );
1234- if ($type eq 'count' ){
1235- return scalar @color_schemes;
1236- }
1237- if ($type eq 'full' ){
1238- return @color_schemes;
1239- }
1240- else {
1241- return @{$color_schemes[$type]};
1242- # print Dumper $color_schemes[$scheme_nu];
1243- }
1244- eval $end if $b_log;
1245+ my ($type) = @_;
1246+ eval $start if $b_log;
1247+ my @color_schemes = (
1248+ [qw(EMPTY EMPTY EMPTY)],
1249+ [qw(NORMAL NORMAL NORMAL)],
1250+ # for dark OR light backgrounds
1251+ [qw(BLUE NORMAL NORMAL)],
1252+ [qw(BLUE RED NORMAL)],
1253+ [qw(CYAN BLUE NORMAL)],
1254+ [qw(DCYAN NORMAL NORMAL)],
1255+ [qw(DCYAN BLUE NORMAL)],
1256+ [qw(DGREEN NORMAL NORMAL)],
1257+ [qw(DYELLOW NORMAL NORMAL)],
1258+ [qw(GREEN DGREEN NORMAL)],
1259+ [qw(GREEN NORMAL NORMAL)],
1260+ [qw(MAGENTA NORMAL NORMAL)],
1261+ [qw(RED NORMAL NORMAL)],
1262+ # for light backgrounds
1263+ [qw(BLACK DGREY NORMAL)],
1264+ [qw(DBLUE DGREY NORMAL)],
1265+ [qw(DBLUE DMAGENTA NORMAL)],
1266+ [qw(DBLUE DRED NORMAL)],
1267+ [qw(DBLUE BLACK NORMAL)],
1268+ [qw(DGREEN DYELLOW NORMAL)],
1269+ [qw(DYELLOW BLACK NORMAL)],
1270+ [qw(DMAGENTA BLACK NORMAL)],
1271+ [qw(DCYAN DBLUE NORMAL)],
1272+ # for dark backgrounds
1273+ [qw(WHITE GREY NORMAL)],
1274+ [qw(GREY WHITE NORMAL)],
1275+ [qw(CYAN GREY NORMAL)],
1276+ [qw(GREEN WHITE NORMAL)],
1277+ [qw(GREEN YELLOW NORMAL)],
1278+ [qw(YELLOW WHITE NORMAL)],
1279+ [qw(MAGENTA CYAN NORMAL)],
1280+ [qw(MAGENTA YELLOW NORMAL)],
1281+ [qw(RED CYAN NORMAL)],
1282+ [qw(RED WHITE NORMAL)],
1283+ [qw(BLUE WHITE NORMAL)],
1284+ # miscellaneous
1285+ [qw(RED BLUE NORMAL)],
1286+ [qw(RED DBLUE NORMAL)],
1287+ [qw(BLACK BLUE NORMAL)],
1288+ [qw(BLACK DBLUE NORMAL)],
1289+ [qw(NORMAL BLUE NORMAL)],
1290+ [qw(BLUE MAGENTA NORMAL)],
1291+ [qw(DBLUE MAGENTA NORMAL)],
1292+ [qw(BLACK MAGENTA NORMAL)],
1293+ [qw(MAGENTA BLUE NORMAL)],
1294+ [qw(MAGENTA DBLUE NORMAL)],
1295+ );
1296+ eval $end if $b_log;
1297+ if ($type eq 'count'){
1298+ return scalar @color_schemes;
1299+ }
1300+ if ($type eq 'full'){
1301+ return @color_schemes;
1302+ }
1303+ else {
1304+ return @{$color_schemes[$type]};
1305+ # print Dumper $color_schemes[$scheme_nu];
1306+ }
1307 }
1308
1309 sub set_color_scheme {
1310- eval $start if $b_log;
1311- my ($scheme) = @_;
1312- $colors{'scheme'} = $scheme;
1313- my $index = ( $b_irc ) ? 1 : 0; # defaults to non irc
1314-
1315- # NOTE: qw(...) kills the escape, it is NOT the same as using
1316- # Literal "..", ".." despite docs saying it is.
1317- my %color_palette = (
1318- 'EMPTY' => [ '', '' ],
1319- 'DGREY' => [ "\e[1;30m", "\x0314" ],
1320- 'BLACK' => [ "\e[0;30m", "\x0301" ],
1321- 'RED' => [ "\e[1;31m", "\x0304" ],
1322- 'DRED' => [ "\e[0;31m", "\x0305" ],
1323- 'GREEN' => [ "\e[1;32m", "\x0309" ],
1324- 'DGREEN' => [ "\e[0;32m", "\x0303" ],
1325- 'YELLOW' => [ "\e[1;33m", "\x0308" ],
1326- 'DYELLOW' => [ "\e[0;33m", "\x0307" ],
1327- 'BLUE' => [ "\e[1;34m", "\x0312" ],
1328- 'DBLUE' => [ "\e[0;34m", "\x0302" ],
1329- 'MAGENTA' => [ "\e[1;35m", "\x0313" ],
1330- 'DMAGENTA' => [ "\e[0;35m", "\x0306" ],
1331- 'CYAN' => [ "\e[1;36m", "\x0311" ],
1332- 'DCYAN' => [ "\e[0;36m", "\x0310" ],
1333- 'WHITE' => [ "\e[1;37m", "\x0300" ],
1334- 'GREY' => [ "\e[0;37m", "\x0315" ],
1335- 'NORMAL' => [ "\e[0m", "\x03" ],
1336- );
1337- my @scheme = get_color_scheme($colors{'scheme'});
1338- $colors{'c1'} = $color_palette{$scheme[0]}[$index];
1339- $colors{'c2'} = $color_palette{$scheme[1]}[$index];
1340- $colors{'cn'} = $color_palette{$scheme[2]}[$index];
1341- # print Dumper \@scheme;
1342- # print "$colors{'c1'}here$colors{'c2'} we are!$colors{'cn'}\n";
1343- eval $end if $b_log;
1344+ eval $start if $b_log;
1345+ my ($scheme) = @_;
1346+ $colors{'scheme'} = $scheme;
1347+ my $index = ($b_irc) ? 1 : 0; # defaults to non irc
1348+
1349+ # NOTE: qw(...) kills the escape, it is NOT the same as using
1350+ # Literal "..", ".." despite docs saying it is.
1351+ my %color_palette = (
1352+ 'EMPTY' => [ '', '' ],
1353+ 'DGREY' => [ "\e[1;30m", "\x0314" ],
1354+ 'BLACK' => [ "\e[0;30m", "\x0301" ],
1355+ 'RED' => [ "\e[1;31m", "\x0304" ],
1356+ 'DRED' => [ "\e[0;31m", "\x0305" ],
1357+ 'GREEN' => [ "\e[1;32m", "\x0309" ],
1358+ 'DGREEN' => [ "\e[0;32m", "\x0303" ],
1359+ 'YELLOW' => [ "\e[1;33m", "\x0308" ],
1360+ 'DYELLOW' => [ "\e[0;33m", "\x0307" ],
1361+ 'BLUE' => [ "\e[1;34m", "\x0312" ],
1362+ 'DBLUE' => [ "\e[0;34m", "\x0302" ],
1363+ 'MAGENTA' => [ "\e[1;35m", "\x0313" ],
1364+ 'DMAGENTA' => [ "\e[0;35m", "\x0306" ],
1365+ 'CYAN' => [ "\e[1;36m", "\x0311" ],
1366+ 'DCYAN' => [ "\e[0;36m", "\x0310" ],
1367+ 'WHITE' => [ "\e[1;37m", "\x0300" ],
1368+ 'GREY' => [ "\e[0;37m", "\x0315" ],
1369+ 'NORMAL' => [ "\e[0m", "\x03" ],
1370+ );
1371+ my @scheme = get_color_scheme($colors{'scheme'});
1372+ $colors{'c1'} = $color_palette{$scheme[0]}->[$index];
1373+ $colors{'c2'} = $color_palette{$scheme[1]}->[$index];
1374+ $colors{'cn'} = $color_palette{$scheme[2]}->[$index];
1375+ # print Dumper \@scheme;
1376+ # print "$colors{'c1'}here$colors{'c2'} we are!$colors{'cn'}\n";
1377+ eval $end if $b_log;
1378 }
1379
1380 sub set_colors {
1381- eval $start if $b_log;
1382- # it's already been set with -c 0-43
1383- if ( exists $colors{'c1'} ){
1384- return 1;
1385- }
1386- # This let's user pick their color scheme. For IRC, only shows the color schemes,
1387- # no interactive. The override value only will be placed in user config files.
1388- # /etc/inxi.conf can also override
1389- if (exists $colors{'selector'}){
1390- my $ob_selector = SelectColors->new($colors{'selector'});
1391- $ob_selector->select_schema();
1392- return 1;
1393- }
1394- # set the default, then override as required
1395- my $color_scheme = $colors{'default'};
1396- # these are set in user configs
1397- if (defined $colors{'global'}){
1398- $color_scheme = $colors{'global'};
1399- }
1400- else {
1401- if ( $b_irc ){
1402- if (defined $colors{'irc-virt-term'} && $b_display && $client{'console-irc'}){
1403- $color_scheme = $colors{'irc-virt-term'};
1404- }
1405- elsif (defined $colors{'irc-console'} && !$b_display){
1406- $color_scheme = $colors{'irc-console'};
1407- }
1408- elsif ( defined $colors{'irc-gui'}) {
1409- $color_scheme = $colors{'irc-gui'};
1410- }
1411- }
1412- else {
1413- if (defined $colors{'console'} && !$b_display){
1414- $color_scheme = $colors{'console'};
1415- }
1416- elsif (defined $colors{'virt-term'}){
1417- $color_scheme = $colors{'virt-term'};
1418- }
1419- }
1420- }
1421- # force 0 for | or > output, all others prints to irc or screen
1422- if (!$b_irc && ! -t STDOUT ){
1423- $color_scheme = 0;
1424- }
1425- set_color_scheme($color_scheme);
1426- eval $end if $b_log;
1427+ eval $start if $b_log;
1428+ # it's already been set with -c 0-43
1429+ if (exists $colors{'c1'}){
1430+ return 1;
1431+ }
1432+ # This let's user pick their color scheme. For IRC, only shows the color
1433+ # schemes, no interactive. The override value only will be placed in user
1434+ # config files. /etc/inxi.conf can also override
1435+ if (exists $colors{'selector'}){
1436+ my $ob_selector = SelectColors->new($colors{'selector'});
1437+ $ob_selector->select_schema();
1438+ return 1;
1439+ }
1440+ # set the default, then override as required
1441+ my $color_scheme = $colors{'default'};
1442+ # these are set in user configs
1443+ if (defined $colors{'global'}){
1444+ $color_scheme = $colors{'global'};
1445+ }
1446+ else {
1447+ if ($b_irc){
1448+ if (defined $colors{'irc-virt-term'} && $b_display && $client{'console-irc'}){
1449+ $color_scheme = $colors{'irc-virt-term'};
1450+ }
1451+ elsif (defined $colors{'irc-console'} && !$b_display){
1452+ $color_scheme = $colors{'irc-console'};
1453+ }
1454+ elsif (defined $colors{'irc-gui'}){
1455+ $color_scheme = $colors{'irc-gui'};
1456+ }
1457+ }
1458+ else {
1459+ if (defined $colors{'console'} && !$b_display){
1460+ $color_scheme = $colors{'console'};
1461+ }
1462+ elsif (defined $colors{'virt-term'}){
1463+ $color_scheme = $colors{'virt-term'};
1464+ }
1465+ }
1466+ }
1467+ # force 0 for | or > output, all others prints to irc or screen
1468+ if (!$b_irc && ! -t STDOUT){
1469+ $color_scheme = 0;
1470+ }
1471+ set_color_scheme($color_scheme);
1472+ eval $end if $b_log;
1473 }
1474
1475 ## SelectColors
1476 {
1477 package SelectColors;
1478-
1479-# use warnings;
1480-# use strict;
1481-# use diagnostics;
1482-# use 5.008;
1483-
1484-my (@data,@rows,%configs,%status);
1485+my (@data,%configs,%status);
1486 my ($type,$w_fh);
1487 my $safe_color_count = 12; # null/normal + default color group
1488 my $count = 0;
1489-
1490 # args: 1 - type
1491 sub new {
1492- my $class = shift;
1493- ($type) = @_;
1494- my $self = {};
1495- return bless $self, $class;
1496+ my $class = shift;
1497+ ($type) = @_;
1498+ my $self = {};
1499+ return bless $self, $class;
1500 }
1501 sub select_schema {
1502- eval $start if $b_log;
1503- assign_selectors();
1504- main::set_color_scheme(0);
1505- set_status();
1506- start_selector();
1507- create_color_selections();
1508- if (! $b_irc ){
1509- main::check_config_file();
1510- get_selection();
1511- }
1512- else {
1513- print_irc_message();
1514- }
1515- eval $end if $b_log;
1516+ eval $start if $b_log;
1517+ assign_selectors();
1518+ main::set_color_scheme(0);
1519+ set_status();
1520+ start_selector();
1521+ create_color_selections();
1522+ if (!$b_irc){
1523+ Configs::check_file();
1524+ get_selection();
1525+ }
1526+ else {
1527+ print_irc_message();
1528+ }
1529+ eval $end if $b_log;
1530 }
1531
1532 sub set_status {
1533- $status{'console'} = (defined $colors{'console'}) ? "Set: $colors{'console'}" : 'Not Set';
1534- $status{'virt-term'} = (defined $colors{'virt-term'}) ? "Set: $colors{'virt-term'}" : 'Not Set';
1535- $status{'irc-console'} = (defined $colors{'irc-console'}) ? "Set: $colors{'irc-console'}" : 'Not Set';
1536- $status{'irc-gui'} = (defined $colors{'irc-gui'}) ? "Set: $colors{'irc-gui'}" : 'Not Set';
1537- $status{'irc-virt-term'} = (defined $colors{'irc-virt-term'}) ? "Set: $colors{'irc-virt-term'}" : 'Not Set';
1538- $status{'global'} = (defined $colors{'global'}) ? "Set: $colors{'global'}" : 'Not Set';
1539+ $status{'console'} = (defined $colors{'console'}) ? "Set: $colors{'console'}" : 'Not Set';
1540+ $status{'virt-term'} = (defined $colors{'virt-term'}) ? "Set: $colors{'virt-term'}" : 'Not Set';
1541+ $status{'irc-console'} = (defined $colors{'irc-console'}) ? "Set: $colors{'irc-console'}" : 'Not Set';
1542+ $status{'irc-gui'} = (defined $colors{'irc-gui'}) ? "Set: $colors{'irc-gui'}" : 'Not Set';
1543+ $status{'irc-virt-term'} = (defined $colors{'irc-virt-term'}) ? "Set: $colors{'irc-virt-term'}" : 'Not Set';
1544+ $status{'global'} = (defined $colors{'global'}) ? "Set: $colors{'global'}" : 'Not Set';
1545 }
1546
1547 sub assign_selectors {
1548- if ($type == 94){
1549- $configs{'variable'} = 'CONSOLE_COLOR_SCHEME';
1550- $configs{'selection'} = 'console';
1551- }
1552- elsif ($type == 95){
1553- $configs{'variable'} = 'VIRT_TERM_COLOR_SCHEME';
1554- $configs{'selection'} = 'virt-term';
1555- }
1556- elsif ($type == 96){
1557- $configs{'variable'} = 'IRC_COLOR_SCHEME';
1558- $configs{'selection'} = 'irc-gui';
1559- }
1560- elsif ($type == 97){
1561- $configs{'variable'} = 'IRC_X_TERM_COLOR_SCHEME';
1562- $configs{'selection'} = 'irc-virt-term';
1563- }
1564- elsif ($type == 98){
1565- $configs{'variable'} = 'IRC_CONS_COLOR_SCHEME';
1566- $configs{'selection'} = 'irc-console';
1567- }
1568- elsif ($type == 99){
1569- $configs{'variable'} = 'GLOBAL_COLOR_SCHEME';
1570- $configs{'selection'} = 'global';
1571- }
1572+ if ($type == 94){
1573+ $configs{'variable'} = 'CONSOLE_COLOR_SCHEME';
1574+ $configs{'selection'} = 'console';
1575+ }
1576+ elsif ($type == 95){
1577+ $configs{'variable'} = 'VIRT_TERM_COLOR_SCHEME';
1578+ $configs{'selection'} = 'virt-term';
1579+ }
1580+ elsif ($type == 96){
1581+ $configs{'variable'} = 'IRC_COLOR_SCHEME';
1582+ $configs{'selection'} = 'irc-gui';
1583+ }
1584+ elsif ($type == 97){
1585+ $configs{'variable'} = 'IRC_X_TERM_COLOR_SCHEME';
1586+ $configs{'selection'} = 'irc-virt-term';
1587+ }
1588+ elsif ($type == 98){
1589+ $configs{'variable'} = 'IRC_CONS_COLOR_SCHEME';
1590+ $configs{'selection'} = 'irc-console';
1591+ }
1592+ elsif ($type == 99){
1593+ $configs{'variable'} = 'GLOBAL_COLOR_SCHEME';
1594+ $configs{'selection'} = 'global';
1595+ }
1596 }
1597 sub start_selector {
1598- my $whoami = getpwuid($<) || "unknown???";
1599- if ( ! $b_irc ){
1600- @data = (
1601- [ 0, '', '', "Welcome to $self_name! Please select the default
1602- $configs{'selection'} color scheme."],
1603- );
1604- }
1605- @rows = (
1606- [ 0, '', '', "Because there is no way to know your $configs{'selection'}
1607- foreground/background colors, you can set your color preferences from
1608- color scheme option list below:"],
1609- [ 0, '', '', "0 is no colors; 1 is neutral."],
1610- [ 0, '', '', "After these, there are 4 sets:"],
1611- [ 0, '', '', "1-dark^or^light^backgrounds; 2-light^backgrounds;
1612- 3-dark^backgrounds; 4-miscellaneous"],
1613- [ 0, '', '', ""],
1614- );
1615- push @data, @rows;
1616- if ( ! $b_irc ){
1617- @rows = (
1618- [ 0, '', '', "Please note that this will set the $configs{'selection'}
1619- preferences only for user: $whoami"],
1620- );
1621- push @data, @rows;
1622- }
1623- @rows = (
1624- [ 0, '', '', "$line1"],
1625- );
1626- push @data, @rows;
1627- main::print_basic(@data);
1628- @data = ();
1629+ my $whoami = getpwuid($<) || "unknown???";
1630+ if (!$b_irc){
1631+ @data = (
1632+ [ 0, '', '', "Welcome to $self_name! Please select the default
1633+ $configs{'selection'} color scheme."],
1634+ );
1635+ }
1636+ push(@data,
1637+ [ 0, '', '', "Because there is no way to know your $configs{'selection'}
1638+ foreground/background colors, you can set your color preferences from
1639+ color scheme option list below:"],
1640+ [ 0, '', '', "0 is no colors; 1 is neutral."],
1641+ [ 0, '', '', "After these, there are 4 sets:"],
1642+ [ 0, '', '', "1-dark^or^light^backgrounds; 2-light^backgrounds;
1643+ 3-dark^backgrounds; 4-miscellaneous"],
1644+ [ 0, '', '', ""],
1645+ );
1646+ if (!$b_irc){
1647+ push(@data,
1648+ [ 0, '', '', "Please note that this will set the $configs{'selection'}
1649+ preferences only for user: $whoami"],
1650+ );
1651+ }
1652+ push(@data,
1653+ [ 0, '', '', "$line1"],
1654+ );
1655+ main::print_basic(\@data);
1656+ @data = ();
1657 }
1658 sub create_color_selections {
1659- my $spacer = '^^'; # printer removes double spaces, but replaces ^ with ' '
1660- $count = ( main::get_color_scheme('count') - 1 );
1661- for my $i (0 .. $count){
1662- if ($i > 9){
1663- $spacer = '^';
1664- }
1665- if ($configs{'selection'} =~ /^(global|irc-gui|irc-console|irc-virt-term)$/ && $i > $safe_color_count ){
1666- last;
1667- }
1668- main::set_color_scheme($i);
1669- @rows = (
1670- [0, '', '', "$i)$spacer$colors{'c1'}Card:$colors{'c2'}^nVidia^GT218
1671- $colors{'c1'}Display^Server$colors{'c2'}^x11^(X.Org^1.7.7)$colors{'cn'}"],
1672- );
1673- push @data, @rows;
1674- }
1675- main::print_basic(@data);
1676- @data = ();
1677- main::set_color_scheme(0);
1678+ my $spacer = '^^'; # printer removes double spaces, but replaces ^ with ' '
1679+ $count = (main::get_color_scheme('count') - 1);
1680+ foreach my $i (0 .. $count){
1681+ if ($i > 9){
1682+ $spacer = '^';
1683+ }
1684+ if ($configs{'selection'} =~ /^(global|irc-gui|irc-console|irc-virt-term)$/ && $i > $safe_color_count){
1685+ last;
1686+ }
1687+ main::set_color_scheme($i);
1688+ push(@data,
1689+ [0, '', '', "$i)$spacer$colors{'c1'}Card:$colors{'c2'}^nVidia^GT218
1690+ $colors{'c1'}Display^Server$colors{'c2'}^x11^(X.Org^1.7.7)$colors{'cn'}"],
1691+ );
1692+ }
1693+ main::print_basic(\@data);
1694+ @data = ();
1695+ main::set_color_scheme(0);
1696 }
1697 sub get_selection {
1698- my $number = $count + 1;
1699- @data = (
1700- [0, '', '', ($number++) . ")^Remove all color settings. Restore $self_name default."],
1701- [0, '', '', ($number++) . ")^Continue, no changes or config file setting."],
1702- [0, '', '', ($number++) . ")^Exit, use another terminal, or set manually."],
1703- [0, '', '', "$line1"],
1704- [0, '', '', "Simply type the number for the color scheme that looks best to your
1705- eyes for your $configs{'selection'} settings and hit <ENTER>. NOTE: You can bring this
1706- option list up by starting $self_name with option: -c plus one of these numbers:"],
1707- [0, '', '', "94^-^console,^not^in^desktop^-^$status{'console'}"],
1708- [0, '', '', "95^-^terminal,^desktop^-^$status{'virt-term'}"],
1709- [0, '', '', "96^-^irc,^gui,^desktop^-^$status{'irc-gui'}"],
1710- [0, '', '', "97^-^irc,^desktop,^in^terminal^-^$status{'irc-virt-term'}"],
1711- [0, '', '', "98^-^irc,^not^in^desktop^-^$status{'irc-console'}"],
1712- [0, '', '', "99^-^global^-^$status{'global'}"],
1713- [0, '', '', ""],
1714- [0, '', '', "Your selection(s) will be stored here: $user_config_file"],
1715- [0, '', '', "Global overrides all individual color schemes. Individual
1716- schemes remove the global setting."],
1717- [0, '', '', "$line1"],
1718- );
1719- main::print_basic(@data);
1720- @data = ();
1721- my $response = <STDIN>;
1722- chomp $response;
1723- if (!main::is_int($response) || $response > ($count + 3) ){
1724- @data = (
1725- [0, '', '', "Error - Invalid Selection. You entered this: $response. Hit <ENTER> to continue."],
1726- [0, '', '', "$line1"],
1727- );
1728- main::print_basic(@data);
1729- my $response = <STDIN>;
1730- start_selector();
1731- create_color_selections();
1732- get_selection();
1733- }
1734- else {
1735- process_selection($response);
1736- }
1737+ my $number = $count + 1;
1738+ @data = (
1739+ [0, '', '', ($number++) . ")^Remove all color settings. Restore $self_name default."],
1740+ [0, '', '', ($number++) . ")^Continue, no changes or config file setting."],
1741+ [0, '', '', ($number++) . ")^Exit, use another terminal, or set manually."],
1742+ [0, '', '', "$line1"],
1743+ [0, '', '', "Simply type the number for the color scheme that looks best to your
1744+ eyes for your $configs{'selection'} settings and hit <ENTER>. NOTE: You can bring this
1745+ option list up by starting $self_name with option: -c plus one of these numbers:"],
1746+ [0, '', '', "94^-^console,^not^in^desktop^-^$status{'console'}"],
1747+ [0, '', '', "95^-^terminal,^desktop^-^$status{'virt-term'}"],
1748+ [0, '', '', "96^-^irc,^gui,^desktop^-^$status{'irc-gui'}"],
1749+ [0, '', '', "97^-^irc,^desktop,^in^terminal^-^$status{'irc-virt-term'}"],
1750+ [0, '', '', "98^-^irc,^not^in^desktop^-^$status{'irc-console'}"],
1751+ [0, '', '', "99^-^global^-^$status{'global'}"],
1752+ [0, '', '', ""],
1753+ [0, '', '', "Your selection(s) will be stored here: $user_config_file"],
1754+ [0, '', '', "Global overrides all individual color schemes. Individual
1755+ schemes remove the global setting."],
1756+ [0, '', '', "$line1"],
1757+ );
1758+ main::print_basic(\@data);
1759+ @data = ();
1760+ my $response = <STDIN>;
1761+ chomp($response);
1762+ if (!main::is_int($response) || $response > ($count + 3)){
1763+ @data = (
1764+ [0, '', '', "Error - Invalid Selection. You entered this: $response. Hit <ENTER> to continue."],
1765+ [0, '', '', "$line1"],
1766+ );
1767+ main::print_basic(\@data);
1768+ my $response = <STDIN>;
1769+ start_selector();
1770+ create_color_selections();
1771+ get_selection();
1772+ }
1773+ else {
1774+ process_selection($response);
1775+ }
1776+ if ($b_pledge){
1777+ @pledges = grep {$_ ne 'getpw'} @pledges;
1778+ OpenBSD::Pledge::pledge(@pledges);
1779+ }
1780 }
1781 sub process_selection {
1782- my $response = shift;
1783- if ($response == ($count + 3) ){
1784- @data = ([0, '', '', "Ok, exiting $self_name now. You can set the colors later."],);
1785- main::print_basic(@data);
1786- exit 0;
1787- }
1788- elsif ($response == ($count + 2)){
1789- @data = (
1790- [0, '', '', "Ok, continuing $self_name unchanged."],
1791- [0, '', '', "$line1"],
1792- );
1793- main::print_basic(@data);
1794- if ( defined $colors{'console'} && !$b_display ){
1795- main::set_color_scheme($colors{'console'});
1796- }
1797- if ( defined $colors{'virt-term'} ){
1798- main::set_color_scheme($colors{'virt-term'});
1799- }
1800- else {
1801- main::set_color_scheme($colors{'default'});
1802- }
1803- }
1804- elsif ($response == ($count + 1)){
1805- @data = (
1806- [0, '', '', "Removing all color settings from config file now..."],
1807- [0, '', '', "$line1"],
1808- );
1809- main::print_basic(@data);
1810- delete_all_config_colors();
1811- main::set_color_scheme($colors{'default'});
1812- }
1813- else {
1814- main::set_color_scheme($response);
1815- @data = (
1816- [0, '', '', "Updating config file for $configs{'selection'} color scheme now..."],
1817- [0, '', '', "$line1"],
1818- );
1819- main::print_basic(@data);
1820- if ($configs{'selection'} eq 'global'){
1821- delete_all_colors();
1822- }
1823- else {
1824- delete_global_color();
1825- }
1826- set_config_color_scheme($response);
1827- }
1828+ my $response = shift;
1829+ if ($response == ($count + 3)){
1830+ @data = (
1831+ [0, '', '', "Ok, exiting $self_name now. You can set the colors later."],
1832+ );
1833+ main::print_basic(\@data);
1834+ exit 0;
1835+ }
1836+ elsif ($response == ($count + 2)){
1837+ @data = (
1838+ [0, '', '', "Ok, continuing $self_name unchanged."],
1839+ [0, '', '', "$line1"],
1840+ );
1841+ main::print_basic(\@data);
1842+ if (defined $colors{'console'} && !$b_display){
1843+ main::set_color_scheme($colors{'console'});
1844+ }
1845+ if (defined $colors{'virt-term'}){
1846+ main::set_color_scheme($colors{'virt-term'});
1847+ }
1848+ else {
1849+ main::set_color_scheme($colors{'default'});
1850+ }
1851+ }
1852+ elsif ($response == ($count + 1)){
1853+ @data = (
1854+ [0, '', '', "Removing all color settings from config file now..."],
1855+ [0, '', '', "$line1"],
1856+ );
1857+ main::print_basic(\@data);
1858+ delete_all_config_colors();
1859+ main::set_color_scheme($colors{'default'});
1860+ }
1861+ else {
1862+ main::set_color_scheme($response);
1863+ @data = (
1864+ [0, '', '', "Updating config file for $configs{'selection'} color scheme now..."],
1865+ [0, '', '', "$line1"],
1866+ );
1867+ main::print_basic(\@data);
1868+ if ($configs{'selection'} eq 'global'){
1869+ delete_all_colors();
1870+ }
1871+ else {
1872+ delete_global_color();
1873+ }
1874+ set_config_color_scheme($response);
1875+ }
1876 }
1877 sub delete_all_colors {
1878- my @file_lines = main::reader( $user_config_file );
1879- open( $w_fh, '>', $user_config_file ) or error_handler('open', $user_config_file, $!);
1880- foreach ( @file_lines ) {
1881- if ( $_ !~ /^(CONSOLE_COLOR_SCHEME|GLOBAL_COLOR_SCHEME|IRC_COLOR_SCHEME|IRC_CONS_COLOR_SCHEME|IRC_X_TERM_COLOR_SCHEME|VIRT_TERM_COLOR_SCHEME)/){
1882- print {$w_fh} "$_";
1883- }
1884- }
1885- close $w_fh;
1886+ my @file_lines = main::reader($user_config_file);
1887+ open($w_fh, '>', $user_config_file) or main::error_handler('open', $user_config_file, $!);
1888+ foreach (@file_lines){
1889+ if ($_ !~ /^(CONSOLE_COLOR_SCHEME|GLOBAL_COLOR_SCHEME|IRC_COLOR_SCHEME|IRC_CONS_COLOR_SCHEME|IRC_X_TERM_COLOR_SCHEME|VIRT_TERM_COLOR_SCHEME)/){
1890+ print {$w_fh} "$_";
1891+ }
1892+ }
1893+ close $w_fh;
1894 }
1895 sub delete_global_color {
1896- my @file_lines = main::reader( $user_config_file );
1897- open( $w_fh, '>', $user_config_file ) or error_handler('open', $user_config_file, $!);
1898- foreach ( @file_lines ) {
1899- if ( $_ !~ /^GLOBAL_COLOR_SCHEME/){
1900- print {$w_fh} "$_";
1901- }
1902- }
1903- close $w_fh;
1904+ my @file_lines = main::reader($user_config_file);
1905+ open($w_fh, '>', $user_config_file) or main::error_handler('open', $user_config_file, $!);
1906+ foreach (@file_lines){
1907+ if ($_ !~ /^GLOBAL_COLOR_SCHEME/){
1908+ print {$w_fh} "$_";
1909+ }
1910+ }
1911+ close $w_fh;
1912 }
1913 sub set_config_color_scheme {
1914- my $value = shift;
1915- my @file_lines = main::reader( $user_config_file );
1916- my $b_found = 0;
1917- open( $w_fh, '>', $user_config_file ) or error_handler('open', $user_config_file, $!);
1918- foreach ( @file_lines ) {
1919- if ( $_ =~ /^$configs{'variable'}/ ){
1920- $_ = "$configs{'variable'}=$value";
1921- $b_found = 1;
1922- }
1923- print $w_fh "$_\n";
1924- }
1925- if (! $b_found ){
1926- print $w_fh "$configs{'variable'}=$value\n";
1927- }
1928- close $w_fh;
1929+ my $value = shift;
1930+ my @file_lines = main::reader($user_config_file);
1931+ my $b_found = 0;
1932+ open($w_fh, '>', $user_config_file) or main::error_handler('open', $user_config_file, $!);
1933+ foreach (@file_lines){
1934+ if ($_ =~ /^$configs{'variable'}/){
1935+ $_ = "$configs{'variable'}=$value";
1936+ $b_found = 1;
1937+ }
1938+ print $w_fh "$_\n";
1939+ }
1940+ if (!$b_found){
1941+ print $w_fh "$configs{'variable'}=$value\n";
1942+ }
1943+ close $w_fh;
1944 }
1945
1946 sub print_irc_message {
1947- @data = (
1948- [ 0, '', '', "$line1"],
1949- [ 0, '', '', "After finding the scheme number you like, simply run this again
1950- in a terminal to set the configuration data file for your irc client. You can
1951- set color schemes for the following: start inxi with -c plus:"],
1952- [ 0, '', '', "94 (console,^not^in^desktop^-^$status{'console'})"],
1953- [ 0, '', '', "95 (terminal, desktop^-^$status{'virt-term'})"],
1954- [ 0, '', '', "96 (irc,^gui,^desktop^-^$status{'irc-gui'})"],
1955- [ 0, '', '', "97 (irc,^desktop,^in terminal^-^$status{'irc-virt-term'})"],
1956- [ 0, '', '', "98 (irc,^not^in^desktop^-^$status{'irc-console'})"],
1957- [ 0, '', '', "99 (global^-^$status{'global'})"]
1958- );
1959- main::print_basic(@data);
1960- exit 0;
1961+ @data = (
1962+ [ 0, '', '', "$line1"],
1963+ [ 0, '', '', "After finding the scheme number you like, simply run this again
1964+ in a terminal to set the configuration data file for your irc client. You can
1965+ set color schemes for the following: start inxi with -c plus:"],
1966+ [ 0, '', '', "94 (console,^not^in^desktop^-^$status{'console'})"],
1967+ [ 0, '', '', "95 (terminal, desktop^-^$status{'virt-term'})"],
1968+ [ 0, '', '', "96 (irc,^gui,^desktop^-^$status{'irc-gui'})"],
1969+ [ 0, '', '', "97 (irc,^desktop,^in terminal^-^$status{'irc-virt-term'})"],
1970+ [ 0, '', '', "98 (irc,^not^in^desktop^-^$status{'irc-console'})"],
1971+ [ 0, '', '', "99 (global^-^$status{'global'})"]
1972+ );
1973+ main::print_basic(\@data);
1974+ exit 0;
1975 }
1976
1977 }
1978@@ -1018,100 +1134,158 @@ sub print_irc_message {
1979 #### CONFIGS
1980 #### -------------------------------------------------------------------
1981
1982-sub check_config_file {
1983- $user_config_file = "$user_config_dir/$self_name.conf";
1984- if ( ! -f $user_config_file ){
1985- open( my $fh, '>', $user_config_file ) or error_handler('create', $user_config_file, $!);
1986- }
1987-}
1988-
1989-sub get_configs {
1990- my (@configs) = @_;
1991- my ($key, $val,@config_files);
1992- if (!@configs){
1993- @config_files = (
1994- qq(/etc/$self_name.conf),
1995- qq($user_config_dir/$self_name.conf)
1996- );
1997- }
1998- else {
1999- @config_files = (@configs);
2000- }
2001- # Config files should be passed in an array as a param to this function.
2002- # Default intended use: global @CONFIGS;
2003- foreach (@config_files) {
2004- next unless open (my $fh, '<', "$_");
2005- while (<$fh>) {
2006- chomp;
2007- s/#.*//;
2008- s/^\s+//;
2009- s/\s+$//;
2010- s/'|"//g;
2011- s/true/1/i; # switch to 1/0 perl boolean
2012- s/false/0/i; # switch to 1/0 perl boolean
2013- next unless length;
2014- ($key, $val) = split(/\s*=\s*/, $_, 2);
2015- next unless length($val);
2016- get_config_item($key,$val);
2017- # print "f: $file key: $key val: $val\n";
2018- }
2019- close $fh;
2020- }
2021-}
2022-
2023-# note: someone managed to make a config file with corrupted values, so check int
2024-# explicitly, don't assume it was done correctly.
2025+## Configs
2026+# public: set() check_file()
2027+{
2028+package Configs;
2029+sub set {
2030+ my ($configs) = @_;
2031+ my ($key, $val,@config_files);
2032+ if (!$configs){
2033+ @config_files = (
2034+ qq(/etc/$self_name.conf),
2035+ qq($user_config_dir/$self_name.conf)
2036+ );
2037+ }
2038+ else {
2039+ @config_files = @$configs;
2040+ }
2041+ # Config files should be passed in an array as a param to this function.
2042+ # Default intended use: global @CONFIGS;
2043+ foreach (@config_files){
2044+ next unless open(my $fh, '<', "$_");
2045+ while (<$fh>){
2046+ chomp;
2047+ s/#.*//;
2048+ s/^\s+//;
2049+ s/\s+$//;
2050+ s/'|"//g;
2051+ s/true/1/i; # switch to 1/0 perl boolean
2052+ s/false/0/i; # switch to 1/0 perl boolean
2053+ next unless length;
2054+ ($key, $val) = split(/\s*=\s*/, $_, 2);
2055+ next unless length($val);
2056+ process_item($key,$val);
2057+ # print "f: $file key: $key val: $val\n";
2058+ }
2059+ close $fh;
2060+ }
2061+}
2062+# note: someone managed to make a config file with corrupted values, so check
2063+# int explicitly, don't assume it was done correctly.
2064 # args: 0: key; 1: value
2065-sub get_config_item {
2066- my ($key,$val) = @_;
2067- if ($key eq 'ALLOW_UPDATE' || $key eq 'B_ALLOW_UPDATE') {$b_update = $val if is_int($val)}
2068- elsif ($key eq 'ALLOW_WEATHER' || $key eq 'B_ALLOW_WEATHER') {$b_weather = $val if is_int($val)}
2069- elsif ($key eq 'CPU_SLEEP') {$cpu_sleep = $val if is_numeric($val)}
2070- elsif ($key eq 'DL_TIMEOUT') {$dl_timeout = $val if is_int($val)}
2071- elsif ($key eq 'DOWNLOADER') {
2072- if ($val =~ /^(curl|fetch|ftp|perl|wget)$/){
2073- # this dumps all the other data and resets %dl for only the
2074- # desired downloader.
2075- $val = set_perl_downloader($val);
2076- %dl = ('dl' => $val, $val => 1);
2077- }}
2078- elsif ($key eq 'FILTER_STRING') {$filter_string = $val}
2079- elsif ($key eq 'LANGUAGE') {$language = $val if $val =~ /^(en)$/}
2080- elsif ($key eq 'LIMIT') {$limit = $val if is_int($val)}
2081- elsif ($key eq 'OUTPUT_TYPE') {$output_type = $val if $val =~ /^(json|screen|xml)$/}
2082- elsif ($key eq 'PARTITION_SORT') {$show{'partition-sort'} = $val if ($val =~ /^(dev-base|fs|id|label|percent-used|size|uuid|used)$/) }
2083- elsif ($key eq 'PS_COUNT') {$ps_count = $val if is_int($val) }
2084- elsif ($key eq 'SENSORS_CPU_NO') {$sensors_cpu_nu = $val if is_int($val)}
2085- elsif ($key eq 'SHOW_HOST' || $key eq 'B_SHOW_HOST') { $show{'host'} = $val if is_int($val)}
2086- elsif ($key eq 'USB_SYS') {$b_usb_sys = $val if is_int($val)}
2087- elsif ($key eq 'WEATHER_UNIT') {
2088- $val = lc($val) if $val;
2089- if ($val && $val =~ /^(c|f|cf|fc|i|m|im|mi)$/){
2090- my %units = ('c'=>'m','f'=>'i','cf'=>'mi','fc'=>'im');
2091- $val = $units{$val} if defined $units{$val};
2092- $weather_unit = $val;
2093- }
2094- }
2095- # layout
2096- elsif ($key eq 'CONSOLE_COLOR_SCHEME') {$colors{'console'} = $val if is_int($val)}
2097- elsif ($key eq 'GLOBAL_COLOR_SCHEME') {$colors{'global'} = $val if is_int($val)}
2098- elsif ($key eq 'IRC_COLOR_SCHEME') {$colors{'irc-gui'} = $val if is_int($val)}
2099- elsif ($key eq 'IRC_CONS_COLOR_SCHEME') {$colors{'irc-console'} = $val if is_int($val)}
2100- elsif ($key eq 'IRC_X_TERM_COLOR_SCHEME') {$colors{'irc-virt-term'} = $val if is_int($val)}
2101- elsif ($key eq 'VIRT_TERM_COLOR_SCHEME') {$colors{'virt-term'} = $val if is_int($val)}
2102- # note: not using the old short SEP1/SEP2
2103- elsif ($key eq 'SEP1_IRC') {$sep{'s1-irc'} = $val}
2104- elsif ($key eq 'SEP1_CONSOLE') {$sep{'s1-console'} = $val}
2105- elsif ($key eq 'SEP2_IRC') {$sep{'s2-irc'} = $val}
2106- elsif ($key eq 'SEP2_CONSOLE') {$sep{'s2-console'} = $val}
2107- # size
2108- elsif ($key eq 'COLS_MAX_CONSOLE') {$size{'console'} = $val if is_int($val)}
2109- elsif ($key eq 'COLS_MAX_IRC') {$size{'irc'} = $val if is_int($val)}
2110- elsif ($key eq 'COLS_MAX_NO_DISPLAY') {$size{'no-display'} = $val if is_int($val)}
2111- elsif ($key eq 'INDENT') {$size{'indent'} = $val if is_int($val)}
2112- elsif ($key eq 'INDENT_MIN') {$size{'indent-min'} = $val if is_int($val)}
2113- # print "mc: key: $key val: $val\n";
2114- # print Dumper (keys %size) . "\n";
2115+sub process_item {
2116+ my ($key,$val) = @_;
2117+ if ($key eq 'ALLOW_UPDATE' || $key eq 'B_ALLOW_UPDATE'){
2118+ $use{'update'} = $val if main::is_int($val)}
2119+ elsif ($key eq 'ALLOW_WEATHER' || $key eq 'B_ALLOW_WEATHER'){
2120+ $use{'weather'} = $val if main::is_int($val)}
2121+ elsif ($key eq 'CPU_SLEEP'){
2122+ $cpu_sleep = $val if main::is_numeric($val)}
2123+ elsif ($key eq 'DL_TIMEOUT'){
2124+ $dl_timeout = $val if main::is_int($val)}
2125+ elsif ($key eq 'DOWNLOADER'){
2126+ if ($val =~ /^(curl|fetch|ftp|perl|wget)$/){
2127+ # this dumps all the other data and resets %dl for only the
2128+ # desired downloader.
2129+ $val = main::set_perl_downloader($val);
2130+ %dl = ('dl' => $val, $val => 1);
2131+ }}
2132+ elsif ($key eq 'FILTER_STRING'){
2133+ $filter_string = $val}
2134+ elsif ($key eq 'LANGUAGE'){
2135+ $language = $val if $val =~ /^(en)$/}
2136+ elsif ($key eq 'LIMIT'){
2137+ $limit = $val if main::is_int($val)}
2138+ elsif ($key eq 'OUTPUT_TYPE'){
2139+ $output_type = $val if $val =~ /^(json|screen|xml)$/}
2140+ elsif ($key eq 'NO_DIG'){
2141+ $force{'no-dig'} = $val if main::is_int($val)}
2142+ elsif ($key eq 'NO_DOAS'){
2143+ $force{'no-doas'} = $val if main::is_int($val)}
2144+ elsif ($key eq 'NO_HTML_WAN'){
2145+ $force{'no-html-wan'} = $val if main::is_int($val)}
2146+ elsif ($key eq 'NO_SUDO'){
2147+ $force{'no-sudo'} = $val if main::is_int($val)}
2148+ elsif ($key eq 'PARTITION_SORT'){
2149+ if ($val =~ /^(dev-base|fs|id|label|percent-used|size|uuid|used)$/){
2150+ $show{'partition-sort'} = $val;
2151+ }}
2152+ elsif ($key eq 'PS_COUNT'){
2153+ $ps_count = $val if main::is_int($val) }
2154+ elsif ($key eq 'SENSORS_CPU_NO'){
2155+ $sensors_cpu_nu = $val if main::is_int($val)}
2156+ elsif ($key eq 'SENSORS_EXCLUDE'){
2157+ @sensors_exclude = split(/\s*,\s*/, $val) if $val}
2158+ elsif ($key eq 'SENSORS_USE'){
2159+ @sensors_use = split(/\s*,\s*/, $val) if $val}
2160+ elsif ($key eq 'SHOW_HOST' || $key eq 'B_SHOW_HOST'){
2161+ if (main::is_int($val)){
2162+ $show{'host'} = $val;
2163+ $show{'no-host'} = 1 if !$show{'host'};
2164+ }
2165+ }
2166+ elsif ($key eq 'USB_SYS'){
2167+ $force{'usb-sys'} = $val if main::is_int($val)}
2168+ elsif ($key eq 'WAN_IP_URL'){
2169+ if ($val =~ /^(ht|f)tp[s]?:\//i){
2170+ $wan_url = $val;
2171+ $force{'no-dig'} = 1;
2172+ }
2173+ }
2174+ elsif ($key eq 'WEATHER_SOURCE'){
2175+ $weather_source = $val if main::is_int($val)}
2176+ elsif ($key eq 'WEATHER_UNIT'){
2177+ $val = lc($val) if $val;
2178+ if ($val && $val =~ /^(c|f|cf|fc|i|m|im|mi)$/){
2179+ my %units = ('c'=>'m','f'=>'i','cf'=>'mi','fc'=>'im');
2180+ $val = $units{$val} if defined $units{$val};
2181+ $weather_unit = $val;
2182+ }
2183+ }
2184+ # layout
2185+ elsif ($key eq 'CONSOLE_COLOR_SCHEME'){
2186+ $colors{'console'} = $val if main::is_int($val)}
2187+ elsif ($key eq 'GLOBAL_COLOR_SCHEME'){
2188+ $colors{'global'} = $val if main::is_int($val)}
2189+ elsif ($key eq 'IRC_COLOR_SCHEME'){
2190+ $colors{'irc-gui'} = $val if main::is_int($val)}
2191+ elsif ($key eq 'IRC_CONS_COLOR_SCHEME'){
2192+ $colors{'irc-console'} = $val if main::is_int($val)}
2193+ elsif ($key eq 'IRC_X_TERM_COLOR_SCHEME'){
2194+ $colors{'irc-virt-term'} = $val if main::is_int($val)}
2195+ elsif ($key eq 'VIRT_TERM_COLOR_SCHEME'){
2196+ $colors{'virt-term'} = $val if main::is_int($val)}
2197+ # note: not using the old short SEP1/SEP2
2198+ elsif ($key eq 'SEP1_IRC'){
2199+ $sep{'s1-irc'} = $val}
2200+ elsif ($key eq 'SEP1_CONSOLE'){
2201+ $sep{'s1-console'} = $val}
2202+ elsif ($key eq 'SEP2_IRC'){
2203+ $sep{'s2-irc'} = $val}
2204+ elsif ($key eq 'SEP2_CONSOLE'){
2205+ $sep{'s2-console'} = $val}
2206+ # size
2207+ elsif ($key eq 'COLS_MAX_CONSOLE'){
2208+ $size{'console'} = $val if main::is_int($val)}
2209+ elsif ($key eq 'COLS_MAX_IRC'){
2210+ $size{'irc'} = $val if main::is_int($val)}
2211+ elsif ($key eq 'COLS_MAX_NO_DISPLAY'){
2212+ $size{'no-display'} = $val if main::is_int($val)}
2213+ elsif ($key eq 'INDENT'){
2214+ $size{'indent'} = $val if main::is_int($val)}
2215+ elsif ($key eq 'WRAP_MAX' || $key eq 'INDENT_MIN'){
2216+ $size{'wrap-max'} = $val if main::is_int($val)}
2217+ # print "mc: key: $key val: $val\n";
2218+ # print Dumper (keys %size) . "\n";
2219+}
2220+sub check_file {
2221+ $user_config_file = "$user_config_dir/$self_name.conf";
2222+ if (! -f $user_config_file){
2223+ open(my $fh, '>', $user_config_file) or
2224+ main::error_handler('create', $user_config_file, $!);
2225+ }
2226+}
2227 }
2228
2229 #### -------------------------------------------------------------------
2230@@ -1122,40 +1296,40 @@ sub get_config_item {
2231 # as soon as possible # will have max 3 files, inxi.log, inxi.1.log,
2232 # inxi.2.log
2233 sub begin_logging {
2234- return 1 if $fh_l; # if we want to start logging for testing before options
2235- my $log_file_2="$user_data_dir/$self_name.1.log";
2236- my $log_file_3="$user_data_dir/$self_name.2.log";
2237- my $data = '';
2238- $end='main::log_data("fe", (caller(1))[3], "");';
2239- $start='main::log_data("fs", (caller(1))[3], \@_);';
2240- #$t3 = tv_interval ($t0, [gettimeofday]);
2241- $t3 = eval 'Time::HiRes::tv_interval (\@t0, [Time::HiRes::gettimeofday()]);' if $b_hires;
2242- #print Dumper $@;
2243- my $now = strftime "%Y-%m-%d %H:%M:%S", localtime;
2244- return if $debugger{'timers'};
2245- # do the rotation if logfile exists
2246- if ( -f $log_file ){
2247- # copy if present second to third
2248- if ( -f $log_file_2 ){
2249- rename $log_file_2, $log_file_3 or error_handler('rename', "$log_file_2 -> $log_file_3", "$!");
2250- }
2251- # then copy initial to second
2252- rename $log_file, $log_file_2 or error_handler('rename', "$log_file -> $log_file_2", "$!");
2253- }
2254- # now create the logfile
2255- # print "Opening log file for reading: $log_file\n";
2256- open $fh_l, '>', $log_file or error_handler(4, $log_file, "$!");
2257- # and echo the start data
2258- $data = $line2;
2259- $data .= "START $self_name LOGGING:\n";
2260- $data .= "NOTE: HiRes timer not available.\n" if !$b_hires;
2261- $data .= "$now\n";
2262- $data .= "Elapsed since start: $t3\n";
2263- $data .= "n: $self_name v: $self_version p: $self_patch d: $self_date\n";
2264- $data .= '@paths:' . joiner(\@paths, '::', 'unset') . "\n";
2265- $data .= $line2;
2266-
2267- print $fh_l $data;
2268+ return 1 if $fh_l; # if we want to start logging for testing before options
2269+ my $log_file_2="$user_data_dir/$self_name.1.log";
2270+ my $log_file_3="$user_data_dir/$self_name.2.log";
2271+ my $data = '';
2272+ $end='main::log_data("fe", (caller(1))[3], "");';
2273+ $start='main::log_data("fs", (caller(1))[3], \@_);';
2274+ #$t3 = tv_interval ($t0, [gettimeofday]);
2275+ $t3 = eval 'Time::HiRes::tv_interval (\@t0, [Time::HiRes::gettimeofday()]);' if $b_hires;
2276+ # print Dumper $@;
2277+ my $now = strftime "%Y-%m-%d %H:%M:%S", localtime;
2278+ return if $debugger{'timers'};
2279+ # do the rotation if logfile exists
2280+ if (-f $log_file){
2281+ # copy if present second to third
2282+ if (-f $log_file_2){
2283+ rename $log_file_2, $log_file_3 or error_handler('rename', "$log_file_2 -> $log_file_3", "$!");
2284+ }
2285+ # then copy initial to second
2286+ rename $log_file, $log_file_2 or error_handler('rename', "$log_file -> $log_file_2", "$!");
2287+ }
2288+ # now create the logfile
2289+ # print "Opening log file for reading: $log_file\n";
2290+ open($fh_l, '>', $log_file) or error_handler(4, $log_file, "$!");
2291+ # and echo the start data
2292+ $data = $line2;
2293+ $data .= "START $self_name LOGGING:\n";
2294+ $data .= "NOTE: HiRes timer not available.\n" if !$b_hires;
2295+ $data .= "$now\n";
2296+ $data .= "Elapsed since start: $t3\n";
2297+ $data .= "n: $self_name v: $self_version p: $self_patch d: $self_date\n";
2298+ $data .= '@paths:' . joiner(\@paths, '::', 'unset') . "\n";
2299+ $data .= $line2;
2300+
2301+ print $fh_l $data;
2302 }
2303
2304 # NOTE: no logging available until get_parameters is run, since that's what
2305@@ -1166,985 +1340,1120 @@ sub begin_logging {
2306 # arg: $one type (fs/fe/cat/dump/raw) or logged data;
2307 # [$two is function name; [$three - function args]]
2308 sub log_data {
2309- return if ! $b_log;
2310- my ($one, $two, $three) = @_;
2311- my ($args,$data,$timer) = ('','','');
2312- my $spacer = ' ';
2313- # print "1: $one 2: $two 3: $three\n";
2314- if ($one eq 'fs') {
2315- if (ref $three eq 'ARRAY'){
2316- my @temp = @$three;
2317- # print Data::Dumper::Dumper \@$three;
2318- $args = "\n${spacer}Args: " . joiner($three, '; ', 'unset');
2319- }
2320- else {
2321- $args = "\n${spacer}Args: None";
2322- }
2323- # $t1 = [gettimeofday];
2324- #$t3 = tv_interval ($t0, [gettimeofday]);
2325- $t3 = eval 'Time::HiRes::tv_interval(\@t0, [Time::HiRes::gettimeofday()])' if $b_hires;
2326- #print Dumper $@;
2327- $data = "Start: Function: $two$args\n${spacer}Elapsed: $t3\n";
2328- $spacer='';
2329- $timer = $data if $debugger{'timers'};
2330- }
2331- elsif ( $one eq 'fe') {
2332- # print 'timer:', Time::HiRes::tv_interval(\@t0, [Time::HiRes::gettimeofday()]),"\n";
2333- #$t3 = tv_interval ($t0, [gettimeofday]);
2334- eval '$t3 = Time::HiRes::tv_interval(\@t0, [Time::HiRes::gettimeofday()])' if $b_hires;
2335- #print Dumper $t3;
2336- $data = "${spacer}Elapsed: $t3\nEnd: Function: $two\n";
2337- $spacer='';
2338- $timer = $data if $debugger{'timers'};
2339- }
2340- elsif ( $one eq 'cat') {
2341- if ( $b_log_full ){
2342- for my $file ($two){
2343- my $contents = do { local( @ARGV, $/ ) = $file; <> }; # or: qx(cat $file)
2344- $data = "$data${line3}Full file data: $file\n\n$contents\n$line3\n";
2345- }
2346- $spacer='';
2347- }
2348- }
2349- elsif ($one eq 'cmd'){
2350- $data = "Command: $two\n";
2351- $data .= qx($two);
2352- }
2353- elsif ($one eq 'data'){
2354- $data = "$two\n";
2355- }
2356- elsif ( $one eq 'dump') {
2357- $data = "$two:\n";
2358- if (ref $three eq 'HASH'){
2359- $data .= Data::Dumper::Dumper \%$three;
2360- }
2361- elsif (ref $three eq 'ARRAY'){
2362- # print Data::Dumper::Dumper \@$three;
2363- $data .= Data::Dumper::Dumper \@$three;
2364- }
2365- else {
2366- $data .= Data::Dumper::Dumper $three;
2367- }
2368- $data .= "\n";
2369- # print $data;
2370- }
2371- elsif ( $one eq 'raw') {
2372- if ( $b_log_full ){
2373- $data = "\n${line3}Raw System Data:\n\n$two\n$line3";
2374- $spacer='';
2375- }
2376- }
2377- else {
2378- $data = "$two\n";
2379- }
2380- if ($debugger{'timers'}){
2381- print $timer if $timer;
2382- }
2383- #print "d: $data";
2384- elsif ($data){
2385- print $fh_l "$spacer$data";
2386- }
2387+ return if !$b_log;
2388+ my ($one, $two, $three) = @_;
2389+ my ($args,$data,$timer) = ('','','');
2390+ my $spacer = ' ';
2391+ # print "1: $one 2: $two 3: $three\n";
2392+ if ($one eq 'fs'){
2393+ if (ref $three eq 'ARRAY'){
2394+ # print Data::Dumper::Dumper $three;
2395+ $args = "\n${spacer}Args: " . joiner($three, '; ', 'unset');
2396+ }
2397+ else {
2398+ $args = "\n${spacer}Args: None";
2399+ }
2400+ # $t1 = [gettimeofday];
2401+ #$t3 = tv_interval ($t0, [gettimeofday]);
2402+ $t3 = eval 'Time::HiRes::tv_interval(\@t0, [Time::HiRes::gettimeofday()])' if $b_hires;
2403+ # print Dumper $@;
2404+ $data = "Start: Function: $two$args\n${spacer}Elapsed: $t3\n";
2405+ $spacer='';
2406+ $timer = $data if $debugger{'timers'};
2407+ }
2408+ elsif ($one eq 'fe'){
2409+ # print 'timer:', Time::HiRes::tv_interval(\@t0, [Time::HiRes::gettimeofday()]),"\n";
2410+ #$t3 = tv_interval ($t0, [gettimeofday]);
2411+ eval '$t3 = Time::HiRes::tv_interval(\@t0, [Time::HiRes::gettimeofday()])' if $b_hires;
2412+ # print Dumper $t3;
2413+ $data = "${spacer}Elapsed: $t3\nEnd: Function: $two\n";
2414+ $spacer='';
2415+ $timer = $data if $debugger{'timers'};
2416+ }
2417+ elsif ($one eq 'cat'){
2418+ if ($b_log_full){
2419+ foreach my $file ($two){
2420+ my $contents = do { local(@ARGV, $/) = $file; <> }; # or: qx(cat $file)
2421+ $data = "$data${line3}Full file data: $file\n\n$contents\n$line3\n";
2422+ }
2423+ $spacer='';
2424+ }
2425+ }
2426+ elsif ($one eq 'cmd'){
2427+ $data = "Command: $two\n";
2428+ $data .= qx($two);
2429+ }
2430+ elsif ($one eq 'data'){
2431+ $data = "$two\n";
2432+ }
2433+ elsif ($one eq 'dump'){
2434+ $data = "$two:\n";
2435+ if (ref $three eq 'HASH'){
2436+ $data .= Data::Dumper::Dumper $three;
2437+ }
2438+ elsif (ref $three eq 'ARRAY'){
2439+ # print Data::Dumper::Dumper $three;
2440+ $data .= Data::Dumper::Dumper $three;
2441+ }
2442+ else {
2443+ $data .= Data::Dumper::Dumper $three;
2444+ }
2445+ $data .= "\n";
2446+ # print $data;
2447+ }
2448+ elsif ($one eq 'raw'){
2449+ if ($b_log_full){
2450+ $data = "\n${line3}Raw System Data:\n\n$two\n$line3";
2451+ $spacer='';
2452+ }
2453+ }
2454+ else {
2455+ $data = "$two\n";
2456+ }
2457+ if ($debugger{'timers'}){
2458+ print $timer if $timer;
2459+ }
2460+ # print "d: $data";
2461+ elsif ($data){
2462+ print $fh_l "$spacer$data";
2463+ }
2464 }
2465
2466 sub set_debugger {
2467- user_debug_test_1() if $debugger{'test-1'};
2468- if ( $debug >= 20){
2469- error_handler('not-in-irc', 'debug data generator') if $b_irc;
2470- my $option = ( $debug > 22 ) ? 'main-full' : 'main';
2471- $debugger{'gz'} = 1 if ($debug == 22 || $debug == 24);
2472- my $ob_sys = SystemDebugger->new($option);
2473- $ob_sys->run_debugger();
2474- $ob_sys->upload_file($ftp_alt) if $debug > 20;
2475- exit 0;
2476- }
2477- elsif ($debug >= 10 && $debug <= 12){
2478- $b_log = 1;
2479- if ($debug == 11){
2480- $b_log_full = 1;
2481- }
2482- elsif ($debug == 12){
2483- $b_log_colors = 1;
2484- }
2485- begin_logging();
2486- }
2487- elsif ($debug <= 3){
2488- if ($debug == 3){
2489- $b_log = 1;
2490- $debugger{'timers'} = 1;
2491- begin_logging();
2492- }
2493- else {
2494- $end = '';
2495- $start = '';
2496- }
2497- }
2498+ user_debug_test_1() if $debugger{'test-1'};
2499+ if ($debugger{'level'} >= 20){
2500+ error_handler('not-in-irc', 'debug data generator') if $b_irc;
2501+ my $option = ($debugger{'level'} > 22) ? 'main-full' : 'main';
2502+ $debugger{'gz'} = 1 if ($debugger{'level'} == 22 || $debugger{'level'} == 24);
2503+ my $ob_sys = SystemDebugger->new($option);
2504+ $ob_sys->run_debugger();
2505+ $ob_sys->upload_file($ftp_alt) if $debugger{'level'} > 20;
2506+ exit 0;
2507+ }
2508+ elsif ($debugger{'level'} >= 10 && $debugger{'level'} <= 12){
2509+ $b_log = 1;
2510+ if ($debugger{'level'} == 11){
2511+ $b_log_full = 1;
2512+ }
2513+ elsif ($debugger{'level'} == 12){
2514+ $b_log_colors = 1;
2515+ }
2516+ begin_logging();
2517+ }
2518+ elsif ($debugger{'level'} <= 3){
2519+ if ($debugger{'level'} == 3){
2520+ $b_log = 1;
2521+ $debugger{'timers'} = 1;
2522+ begin_logging();
2523+ }
2524+ else {
2525+ $end = '';
2526+ $start = '';
2527+ }
2528+ }
2529 }
2530
2531 ## SystemDebugger
2532 {
2533 package SystemDebugger;
2534-
2535-# use File::Find q(find);
2536-#no warnings 'File::Find';
2537-# use File::Spec::Functions;
2538-#use File::Copy;
2539-#use POSIX qw(strftime);
2540-
2541 my $option = 'main';
2542 my ($data_dir,$debug_dir,$debug_gz,$parse_src,$upload) = ('','','','','');
2543-my @content = ();
2544+my @content;
2545 my $b_debug = 0;
2546 my $b_delete_dir = 1;
2547 # args: 1 - type
2548 # args: 2 - upload
2549 sub new {
2550- my $class = shift;
2551- ($option) = @_;
2552- my $self = {};
2553- # print "$f\n";
2554- # print "$option\n";
2555- return bless $self, $class;
2556+ my $class = shift;
2557+ ($option) = @_;
2558+ my $self = {};
2559+ # print "$f\n";
2560+ # print "$option\n";
2561+ return bless $self, $class;
2562 }
2563
2564 sub run_debugger {
2565- #require File::Find;
2566- #import File::Find::Functions;
2567- require File::Copy;
2568- import File::Copy;
2569- require File::Spec::Functions;
2570- import File::Spec::Functions;
2571-
2572- print "Starting $self_name debugging data collector...\n";
2573- create_debug_directory();
2574- print "Note: for dmidecode data you must be root.\n" if !$b_root;
2575- print $line3;
2576- if (!$b_debug){
2577- audio_data();
2578- disk_data();
2579- display_data();
2580- network_data();
2581- perl_modules();
2582- system_data();
2583- }
2584- system_files();
2585- print $line3;
2586- if (!$b_debug){
2587- # note: android has unreadable /sys, but -x and -r tests pass
2588- # main::globber('/sys/*') &&
2589- if ( main::count_dir_files('/sys') ){
2590- build_tree('sys');
2591- # kernel crash, not sure what creates it, for ppc, as root
2592- sys_traverse_data() if ($debugger{'sys'} && ($debugger{'sys-force'} || !$b_root || !$b_ppc )) ;
2593- }
2594- else {
2595- print "Skipping /sys data collection. /sys not present, or empty.\n";
2596- }
2597- print $line3;
2598- # note: proc has some files that are apparently kernel processes, I've tried
2599- # filtering them out but more keep appearing, so only run proc debugger if not root
2600- if ( !$debugger{'no-proc'} && (!$b_root || $debugger{'proc'} ) && -d '/proc' && main::count_dir_files('/proc') ){
2601- build_tree('proc');
2602- proc_traverse_data();
2603- }
2604- else {
2605- print "Skipping /proc data collection.\n";
2606- }
2607- print $line3;
2608- }
2609- run_self();
2610- print $line3;
2611- compress_dir();
2612+ print "Starting $self_name debugging data collector...\n";
2613+ print "Loading required debugger Perl File:: modules... \n";
2614+ # Fedora/Redhat doesn't include File::Find File::Copy in
2615+ # core modules. why? Or rather, they deliberately removed them.
2616+ if (main::check_perl_module('File::Find')){
2617+ File::Find->import;
2618+ }
2619+ else {
2620+ main::error_handler('required-module', 'File', 'File::Find');
2621+ }
2622+ if (main::check_perl_module('File::Copy')){
2623+ File::Copy->import;
2624+ }
2625+ else {
2626+ main::error_handler('required-module', 'File', 'File::Copy');
2627+ }
2628+ if (main::check_perl_module('File::Spec::Functions')){
2629+ File::Spec::Functions->import;
2630+ }
2631+ else {
2632+ main::error_handler('required-module', 'File', 'File::Spec::Functions');
2633+ }
2634+ if ($debugger{'level'} > 20){
2635+ if (main::check_perl_module('Net::FTP')){
2636+ Net::FTP->import;
2637+ }
2638+ else {
2639+ main::error_handler('required-module', 'Net', 'Net::FTP');
2640+ }
2641+ }
2642+ create_debug_directory();
2643+ print "Note: for dmidecode, smartctl, lvm data you must be root.\n" if !$b_root;
2644+ print $line3;
2645+ if (!$b_debug){
2646+ audio_data();
2647+ bluetooth_data();
2648+ disk_data();
2649+ display_data();
2650+ network_data();
2651+ perl_modules();
2652+ system_data();
2653+ }
2654+ system_files();
2655+ print $line3;
2656+ if (!$b_debug){
2657+ # note: android has unreadable /sys, but -x and -r tests pass
2658+ # main::globber('/sys/*') &&
2659+ if ($debugger{'sys'} && main::count_dir_files('/sys')){
2660+ build_tree('sys');
2661+ # kernel crash, not sure what creates it, for ppc, as root
2662+ sys_traverse_data() if ($debugger{'sys'} && ($debugger{'sys-force'} || !$b_root || !$b_ppc)) ;
2663+ }
2664+ else {
2665+ print "Skipping /sys data collection.\n";
2666+ }
2667+ print $line3;
2668+ # note: proc has some files that are apparently kernel processes, I've tried
2669+ # filtering them out but more keep appearing, so only run proc debugger if not root
2670+ if (!$debugger{'no-proc'} && (!$b_root || $debugger{'proc'}) && -d '/proc' && main::count_dir_files('/proc')){
2671+ build_tree('proc');
2672+ proc_traverse_data();
2673+ }
2674+ else {
2675+ print "Skipping /proc data collection.\n";
2676+ }
2677+ print $line3;
2678+ }
2679+ run_self();
2680+ print $line3;
2681+ compress_dir();
2682 }
2683
2684 sub create_debug_directory {
2685- my $host = main::get_hostname();
2686- $host =~ s/ /-/g;
2687- $host = 'no-host' if !$host || $host eq 'N/A';
2688- my ($alt_string,$bsd_string,$root_string) = ('','','');
2689- # note: Time::Piece was introduced in perl 5.9.5
2690- my ($sec,$min,$hour,$mday,$mon,$year) = localtime;
2691- $year = $year+1900;
2692- $mon += 1;
2693- if (length($sec) == 1) {$sec = "0$sec";}
2694- if (length($min) == 1) {$min = "0$min";}
2695- if (length($hour) == 1) {$hour = "0$hour";}
2696- if (length($mon) == 1) {$mon = "0$mon";}
2697- if (length($mday) == 1) {$mday = "0$mday";}
2698-
2699- my $today = "$year-$mon-${mday}_$hour$min$sec";
2700- # my $date = strftime "-%Y-%m-%d_", localtime;
2701- if ($b_root){
2702- $root_string = '-root';
2703- }
2704- $bsd_string = "-BSD-$bsd_type" if $bsd_type;
2705- if ($b_arm ){$alt_string = '-ARM'}
2706- elsif ($b_mips) {$alt_string = '-MIPS'}
2707- elsif ($b_ppc) {$alt_string = '-PPC'}
2708- elsif ($b_sparc) {$alt_string = '-SPARC'}
2709- $debug_dir = "$self_name$alt_string$bsd_string-$host-$today$root_string-$self_version";
2710- $debug_gz = "$debug_dir.tar.gz";
2711- $data_dir = "$user_data_dir/$debug_dir";
2712- if ( -d $data_dir ){
2713- unlink $data_dir or main::error_handler('remove', "$data_dir", "$!");
2714- }
2715- mkdir $data_dir or main::error_handler('mkdir', "$data_dir", "$!");
2716- if ( -e "$user_data_dir/$debug_gz" ){
2717- #rmdir "$user_data_dir$debug_gz" or main::error_handler('remove', "$user_data_dir/$debug_gz", "$!");
2718- print "Failed removing leftover directory:\n$user_data_dir$debug_gz error: $?" if system('rm','-rf',"$user_data_dir$debug_gz");
2719- }
2720- print "Data going into:\n$data_dir\n";
2721+ my $host = main::get_hostname();
2722+ $host =~ s/ /-/g;
2723+ $host = 'no-host' if !$host || $host eq 'N/A';
2724+ my ($alt_string,$bsd_string,$root_string) = ('','','');
2725+ # note: Time::Piece was introduced in perl 5.9.5
2726+ my ($sec,$min,$hour,$mday,$mon,$year) = localtime;
2727+ $year = $year+1900;
2728+ $mon += 1;
2729+ if (length($sec) == 1){$sec = "0$sec";}
2730+ if (length($min) == 1){$min = "0$min";}
2731+ if (length($hour) == 1){$hour = "0$hour";}
2732+ if (length($mon) == 1){$mon = "0$mon";}
2733+ if (length($mday) == 1){$mday = "0$mday";}
2734+ my $today = "$year-$mon-${mday}_$hour$min$sec";
2735+ # my $date = strftime "-%Y-%m-%d_", localtime;
2736+ if ($b_root){
2737+ $root_string = '-root';
2738+ }
2739+ $bsd_string = "-BSD-$bsd_type" if $bsd_type;
2740+ my $id = ($debugger{'id'}) ? '-' . $debugger{'id'}: '';
2741+ if ($b_arm){$alt_string = '-ARM'}
2742+ elsif ($b_mips){$alt_string = '-MIPS'}
2743+ elsif ($b_ppc){$alt_string = '-PPC'}
2744+ elsif ($b_sparc){$alt_string = '-SPARC'}
2745+ $debug_dir = "$self_name$alt_string$bsd_string-$host$id-$today$root_string-$self_version-$self_patch";
2746+ $debug_gz = "$debug_dir.tar.gz";
2747+ $data_dir = "$user_data_dir/$debug_dir";
2748+ if (-d $data_dir){
2749+ unlink $data_dir or main::error_handler('remove', "$data_dir", "$!");
2750+ }
2751+ mkdir $data_dir or main::error_handler('mkdir', "$data_dir", "$!");
2752+ if (-e "$user_data_dir/$debug_gz"){
2753+ #rmdir "$user_data_dir$debug_gz" or main::error_handler('remove', "$user_data_dir/$debug_gz", "$!");
2754+ print "Failed removing leftover directory:\n$user_data_dir$debug_gz error: $?" if system('rm','-rf',"$user_data_dir$debug_gz");
2755+ }
2756+ print "Debugger data going into:\n$data_dir\n";
2757 }
2758 sub compress_dir {
2759- print "Creating tar.gz compressed file of this material...\n";
2760- print "File: $debug_gz\n";
2761- system("cd $user_data_dir; tar -czf $debug_gz $debug_dir");
2762- print "Removing $data_dir...\n";
2763- #rmdir $data_dir or print "failed removing: $data_dir error: $!\n";
2764- return 1 if !$b_delete_dir;
2765- if (system('rm','-rf',$data_dir) ){
2766- print "Failed removing: $data_dir\nError: $?\n";
2767- }
2768- else {
2769- print "Directory removed.\n";
2770- }
2771+ print "Creating tar.gz compressed file of this material...\n";
2772+ print "File: $debug_gz\n";
2773+ system("cd $user_data_dir; tar -czf $debug_gz $debug_dir");
2774+ print "Removing $data_dir...\n";
2775+ #rmdir $data_dir or print "failed removing: $data_dir error: $!\n";
2776+ return 1 if !$b_delete_dir;
2777+ if (system('rm','-rf',$data_dir)){
2778+ print "Failed removing: $data_dir\nError: $?\n";
2779+ }
2780+ else {
2781+ print "Directory removed.\n";
2782+ }
2783 }
2784 # NOTE: incomplete, don't know how to ever find out
2785 # what sound server is actually running, and is in control
2786 sub audio_data {
2787- my (%data,@files,@files2);
2788- print "Collecting audio data...\n";
2789- my @cmds = (
2790- ['aplay', '-l'], # alsa
2791- ['pactl', 'list'], # pulseaudio
2792- );
2793- run_commands(\@cmds,'audio');
2794- @files = main::globber('/proc/asound/card*/codec*');
2795- if (@files){
2796- my $asound = qx(head -n 1 /proc/asound/card*/codec* 2>&1);
2797- $data{'proc-asound-codecs'} = $asound;
2798- }
2799- else {
2800- $data{'proc-asound-codecs'} = undef;
2801- }
2802-
2803- write_data(\%data,'audio');
2804- @files = (
2805- '/proc/asound/cards',
2806- '/proc/asound/version',
2807- );
2808- @files2 = main::globber('/proc/asound/*/usbid');
2809- @files = (@files,@files2) if @files2;
2810- copy_files(\@files,'audio');
2811+ my (%data,@files,@files2);
2812+ print "Collecting audio data...\n";
2813+ my @cmds = (
2814+ ['aplay', '-l'], # alsa
2815+ ['pactl', 'list'], # pulseaudio
2816+ );
2817+ run_commands(\@cmds,'audio');
2818+ @files = main::globber('/proc/asound/card*/codec*');
2819+ if (@files){
2820+ my $asound = qx(head -n 1 /proc/asound/card*/codec* 2>&1);
2821+ $data{'proc-asound-codecs'} = $asound;
2822+ }
2823+ else {
2824+ $data{'proc-asound-codecs'} = undef;
2825+ }
2826+ write_data(\%data,'audio');
2827+ @files = (
2828+ '/proc/asound/cards',
2829+ '/proc/asound/version',
2830+ );
2831+ @files2 = main::globber('/proc/asound/*/usbid');
2832+ push(@files,@files2) if @files2;
2833+ copy_files(\@files,'audio');
2834+}
2835+sub bluetooth_data {
2836+ print "Collecting bluetooth data...\n";
2837+# no warnings 'uninitialized';
2838+ my @cmds = (
2839+ ['hciconfig','-a'],
2840+ #['hcidump',''], # hangs sometimes
2841+ ['hcitool','dev'],
2842+ ['rfkill','--output-all'],
2843+ );
2844+ # these hang if bluetoothd not enabled
2845+ if (@ps_cmd && (grep {m|/bluetoothd|} @ps_cmd)){
2846+ push(@cmds,
2847+ ['bt-adapter','--list'],
2848+ ['bt-adapter','--info'],
2849+ ['bluetoothctl','-- list'],
2850+ ['bluetoothctl','-- show']
2851+ );
2852+ }
2853+ run_commands(\@cmds,'bluetooth');
2854 }
2855+
2856 ## NOTE: >/dev/null 2>&1 is sh, and &>/dev/null is bash, fix this
2857 # ls -w 1 /sysrs > tester 2>&1
2858 sub disk_data {
2859- my (%data,@files,@files2);
2860- print "Collecting dev, label, disk, uuid data, df...\n";
2861- @files = (
2862- '/etc/fstab',
2863- '/etc/mtab',
2864- '/proc/mdstat',
2865- '/proc/mounts',
2866- '/proc/partitions',
2867- '/proc/scsi/scsi',
2868- '/proc/sys/dev/cdrom/info',
2869- );
2870- # very old systems
2871- if (-d '/proc/ide/'){
2872- my @ides = main::globber('/proc/ide/*/*');
2873- @files = (@files, @ides) if @ides;
2874- }
2875- else {
2876- push (@files, '/proc-ide-directory');
2877- }
2878- copy_files(\@files, 'disk');
2879- my @cmds = (
2880- ['blockdev', '--report'],
2881- ['btrfs', 'filesystem show'],
2882- ['btrfs', 'filesystem show --mounted'],
2883- # ['btrfs', 'filesystem show --all-devices'],
2884- ['df', '-h -T'],
2885- ['df', '-h'],
2886- ['df', '-k'],
2887- ['df', '-k -T'],
2888- ['df', '-k -T -P'],
2889- ['df', '-k -T -P -a'],
2890- ['df', '-P'],
2891- ['findmnt', ''],
2892- ['findmnt', '--df --no-truncate'],
2893- ['findmnt', '--list --no-truncate'],
2894- ['lsblk', '-fs'],
2895- ['lsblk', '-fsr'],
2896- ['lsblk', '-fsP'],
2897- ['lsblk', '-a'],
2898- ['lsblk', '-aP'],
2899- ['lsblk', '-ar'],
2900- ['lsblk', '-p'],
2901- ['lsblk', '-pr'],
2902- ['lsblk', '-pP'],
2903- ['lsblk', '-r'],
2904- ['lsblk', '-r --output NAME,PKNAME,TYPE,RM,FSTYPE,SIZE,LABEL,UUID,MOUNTPOINT,PHY-SEC,LOG-SEC'],
2905- ['lsblk', '-rb --output NAME,PKNAME,TYPE,RM,FSTYPE,SIZE,LABEL,UUID,MOUNTPOINT,PHY-SEC,LOG-SEC'],
2906- ['lsblk', '-Pb --output NAME,PKNAME,TYPE,RM,FSTYPE,SIZE'],
2907- ['lsblk', '-Pb --output NAME,TYPE,RM,FSTYPE,SIZE,LABEL,UUID,SERIAL,MOUNTPOINT,PHY-SEC,LOG-SEC'],
2908- ['gpart', 'list'],
2909- ['gpart', 'show'],
2910- ['gpart', 'status'],
2911- ['ls', '-l /dev'],
2912- ['ls', '-l /dev/disk'],
2913- ['ls', '-l /dev/disk/by-id'],
2914- ['ls', '-l /dev/disk/by-label'],
2915- ['ls', '-l /dev/disk/by-uuid'],
2916- # http://comments.gmane.org/gmane.linux.file-systems.zfs.user/2032
2917- ['ls', '-l /dev/disk/by-wwn'],
2918- ['ls', '-l /dev/disk/by-path'],
2919- ['ls', '-l /dev/mapper'],
2920- # LSI raid https://hwraid.le-vert.net/wiki/LSIMegaRAIDSAS
2921- ['megacli', '-AdpAllInfo -aAll'],
2922- ['megacli', '-LDInfo -L0 -a0'],
2923- ['megacli', '-PDList -a0'],
2924- ['megaclisas-status', ''],
2925- ['megaraidsas-status', ''],
2926- ['megasasctl', ''],
2927- ['mount', ''],
2928- ['nvme', 'present'],
2929- ['readlink', '/dev/root'],
2930- ['swapon', '-s'],
2931- # 3ware-raid
2932- ['tw-cli', 'info'],
2933- ['zfs', 'list'],
2934- ['zpool', 'list'],
2935- ['zpool', 'list -v'],
2936- );
2937- run_commands(\@cmds,'disk');
2938- @cmds = (
2939- ['atacontrol', 'list'],
2940- ['camcontrol', 'devlist'],
2941- ['glabel', 'status'],
2942- ['swapctl', '-l -k'],
2943- ['swapctl', '-l -k'],
2944- ['vmstat', '-H'],
2945- );
2946- run_commands(\@cmds,'disk-bsd');
2947+ my (%data,@files,@files2);
2948+ print "Collecting dev, label, disk, uuid data, df...\n";
2949+ @files = (
2950+ '/etc/fstab',
2951+ '/etc/mtab',
2952+ '/proc/devices',
2953+ '/proc/mdstat',
2954+ '/proc/mounts',
2955+ '/proc/partitions',
2956+ '/proc/scsi/scsi',
2957+ '/proc/sys/dev/cdrom/info',
2958+ );
2959+ # very old systems
2960+ if (-d '/proc/ide/'){
2961+ my @ides = main::globber('/proc/ide/*/*');
2962+ push(@files, @ides) if @ides;
2963+ }
2964+ else {
2965+ push(@files, '/proc-ide-directory');
2966+ }
2967+ copy_files(\@files, 'disk');
2968+ my @cmds = (
2969+ ['blockdev', '--report'],
2970+ ['btrfs', 'fi show'],
2971+ ['btrfs', 'filesystem show'],
2972+ ['btrfs', 'filesystem show --mounted'],
2973+ # ['btrfs', 'filesystem show --all-devices'],
2974+ ['df', '-h -T'],
2975+ ['df', '-h'],
2976+ ['df', '-k'],
2977+ ['df', '-k -T'],
2978+ ['df', '-k -T -P'],
2979+ ['df', '-k -T -P -a'],
2980+ ['df', '-P'],
2981+ ['dmsetup', 'ls --tree'],
2982+ ['findmnt', ''],
2983+ ['findmnt', '--df --no-truncate'],
2984+ ['findmnt', '--list --no-truncate'],
2985+ ['gpart', 'list'],
2986+ ['gpart', 'show'],
2987+ ['gpart', 'status'],
2988+ ['ls', '-l /dev'],
2989+ # block is for mmcblk / arm devices
2990+ ['ls', '-l /dev/block'],
2991+ ['ls', '-l /dev/block/bootdevice'],
2992+ ['ls', '-l /dev/block/bootdevice/by-name'],
2993+ ['ls', '-l /dev/disk'],
2994+ ['ls', '-l /dev/disk/by-id'],
2995+ ['ls', '-l /dev/disk/by-label'],
2996+ ['ls', '-l /dev/disk/by-partlabel'],
2997+ ['ls', '-l /dev/disk/by-partuuid'],
2998+ ['ls', '-l /dev/disk/by-path'],
2999+ ['ls', '-l /dev/disk/by-uuid'],
3000+ # http://comments.gmane.org/gmane.linux.file-systems.zfs.user/2032
3001+ ['ls', '-l /dev/disk/by-wwn'],
3002+ ['ls', '-l /dev/mapper'],
3003+ ['lsblk', '-fs'],
3004+ ['lsblk', '-fsr'],
3005+ ['lsblk', '-fsP'],
3006+ ['lsblk', '-a'],
3007+ ['lsblk', '-aP'],
3008+ ['lsblk', '-ar'],
3009+ ['lsblk', '-p'],
3010+ ['lsblk', '-pr'],
3011+ ['lsblk', '-pP'],
3012+ ['lsblk', '-r'],
3013+ ['lsblk', '-r --output NAME,PKNAME,TYPE,RM,FSTYPE,SIZE,LABEL,UUID,MOUNTPOINT,PHY-SEC,LOG-SEC,PARTFLAGS'],
3014+ ['lsblk', '-rb --output NAME,PKNAME,TYPE,RM,FSTYPE,SIZE,LABEL,UUID,MOUNTPOINT,PHY-SEC,LOG-SEC,PARTFLAGS'],
3015+ ['lsblk', '-rb --output NAME,TYPE,RM,FSTYPE,SIZE,LABEL,UUID,SERIAL,MOUNTPOINT,PHY-SEC,LOG-SEC,PARTFLAGS,MAJ:MIN,PKNAME'],
3016+ ['lsblk', '-Pb --output NAME,PKNAME,TYPE,RM,FSTYPE,SIZE'],
3017+ ['lsblk', '-Pb --output NAME,TYPE,RM,FSTYPE,SIZE,LABEL,UUID,SERIAL,MOUNTPOINT,PHY-SEC,LOG-SEC,PARTFLAGS'],
3018+ # this should always be the live command used internally:
3019+ ['lsblk', '-bP --output NAME,TYPE,RM,FSTYPE,SIZE,LABEL,UUID,SERIAL,MOUNTPOINT,PHY-SEC,LOG-SEC,PARTFLAGS,MAJ:MIN,PKNAME'],
3020+ ['lvdisplay', '-c'],
3021+ ['lvdisplay', '-cv'],
3022+ ['lvdisplay', '-cv --segments'],
3023+ ['lvdisplay', '-m --segments'],
3024+ ['lvdisplay', '-ma --segments'],
3025+ ['lvs', '--separator :'],
3026+ ['lvs', '--separator : --segments'],
3027+ ['lvs', '-o +devices --separator : --segments'],
3028+ ['lvs', '-o +devices -v --separator : --segments'],
3029+ ['lvs', '-o +devices -av --separator : --segments'],
3030+ ['lvs', '-o +devices -aPv --separator : --segments'],
3031+ # LSI raid https://hwraid.le-vert.net/wiki/LSIMegaRAIDSAS
3032+ ['megacli', '-AdpAllInfo -aAll'],
3033+ ['megacli', '-LDInfo -L0 -a0'],
3034+ ['megacli', '-PDList -a0'],
3035+ ['megaclisas-status', ''],
3036+ ['megaraidsas-status', ''],
3037+ ['megasasctl', ''],
3038+ ['mount', ''],
3039+ ['nvme', 'present'],
3040+ ['pvdisplay', '-c'],
3041+ ['pvdisplay', '-cv'],
3042+ ['pvdisplay', '-m'],
3043+ ['pvdisplay', '-ma'],
3044+ ['pvs', '--separator :'],
3045+ ['pvs', '--separator : --segments'],
3046+ ['pvs', '-a --separator : --segments'],
3047+ ['pvs', '-av --separator : --segments'],
3048+ ['pvs', '-aPv --separator : --segments -o +pv_major,pv_minor'],
3049+ ['pvs', '-v --separator : --segments'],
3050+ ['pvs', '-Pv --separator : --segments'],
3051+ ['pvs', '--segments -o pv_name,pv_size,seg_size,vg_name,lv_name,lv_size,seg_pe_ranges'],
3052+ ['readlink', '/dev/root'],
3053+ ['swapon', '-s'],
3054+ # 3ware-raid
3055+ ['tw-cli', 'info'],
3056+ ['vgdisplay', ''],
3057+ ['vgdisplay', '-v'],
3058+ ['vgdisplay', '-c'],
3059+ ['vgdisplay', '-vc'],
3060+ ['vgs', '--separator :'],
3061+ ['vgs', '-av --separator :'],
3062+ ['vgs', '-aPv --separator :'],
3063+ ['vgs', '-v --separator :'],
3064+ ['vgs', '-o +pv_name --separator :'],
3065+ ['zfs', 'list'],
3066+ ['zpool', 'list'],
3067+ ['zpool', 'list -v'],
3068+ );
3069+ run_commands(\@cmds,'disk');
3070+ @cmds = (
3071+ ['atacontrol', 'list'],
3072+ ['camcontrol', 'devlist'],
3073+ ['camcontrol', 'devlist -v'],
3074+ ['geom', 'part list'],
3075+ ['glabel', 'status'],
3076+ ['gpart', 'list'], # gpart in linux/bsd but do it here again
3077+ ['gpart', 'show'],
3078+ ['gpart', 'status'],
3079+ ['swapctl', '-l -k'],
3080+ ['swapctl', '-l -k'],
3081+ ['vmstat', ''],
3082+ ['vmstat', '-H'],
3083+ );
3084+ run_commands(\@cmds,'disk-bsd');
3085 }
3086 sub display_data {
3087- my (%data,@files,@files2);
3088- my $working = '';
3089- if ( ! $b_display ){
3090- print "Warning: only some of the data collection can occur if you are not in X\n";
3091- main::toucher("$data_dir/display-data-warning-user-not-in-x");
3092- }
3093- if ( $b_root ){
3094- print "Warning: only some of the data collection can occur if you are running as Root user\n";
3095- main::toucher("$data_dir/display-data-warning-root-user");
3096- }
3097- print "Collecting Xorg log and xorg.conf files...\n";
3098- if ( -d "/etc/X11/xorg.conf.d/" ){
3099- @files = main::globber("/etc/X11/xorg.conf.d/*");
3100- }
3101- else {
3102- @files = ('/xorg-conf-d');
3103- }
3104- push (@files, $files{'xorg-log'});
3105- push (@files, '/etc/X11/xorg.conf');
3106- copy_files(\@files,'display-xorg');
3107- print "Collecting X, xprop, glxinfo, xrandr, xdpyinfo data, wayland, weston...\n";
3108- %data = (
3109- 'desktop-session' => $ENV{'DESKTOP_SESSION'},
3110- 'gdmsession' => $ENV{'GDMSESSION'},
3111- 'gnome-desktop-session-id' => $ENV{'GNOME_DESKTOP_SESSION_ID'},
3112- 'kde-full-session' => $ENV{'KDE_FULL_SESSION'},
3113- 'kde-session-version' => $ENV{'KDE_SESSION_VERSION'},
3114- 'vdpau-driver' => $ENV{'VDPAU_DRIVER'},
3115- 'xdg-current-desktop' => $ENV{'XDG_CURRENT_DESKTOP'},
3116- 'xdg-session-desktop' => $ENV{'XDG_SESSION_DESKTOP'},
3117- 'xdg-vtnr' => $ENV{'XDG_VTNR'},
3118- # wayland data collectors:
3119- 'xdg-session-type' => $ENV{'XDG_SESSION_TYPE'},
3120- 'wayland-display' => $ENV{'WAYLAND_DISPLAY'},
3121- 'gdk-backend' => $ENV{'GDK_BACKEND'},
3122- 'qt-qpa-platform' => $ENV{'QT_QPA_PLATFORM'},
3123- 'clutter-backend' => $ENV{'CLUTTER_BACKEND'},
3124- 'sdl-videodriver' => $ENV{'SDL_VIDEODRIVER'},
3125- # program display values
3126- 'size-indent' => $size{'indent'},
3127- 'size-indent-min' => $size{'indent-min'},
3128- 'size-cols-max' => $size{'max'},
3129- );
3130- write_data(\%data,'display');
3131- my @cmds = (
3132- # kde 5/plasma desktop 5, this is maybe an extra package and won't be used
3133- ['about-distro',''],
3134- ['aticonfig','--adapter=all --od-gettemperature'],
3135- ['glxinfo',''],
3136- ['glxinfo','-B'],
3137- ['kded','--version'],
3138- ['kded1','--version'],
3139- ['kded2','--version'],
3140- ['kded3','--version'],
3141- ['kded4','--version'],
3142- ['kded5','--version'],
3143- ['kded6','--version'],
3144- ['kf4-config','--version'],
3145- ['kf5-config','--version'],
3146- ['kf6-config','--version'],
3147- ['kwin_x11','--version'],
3148- # ['locate','/Xorg'], # for Xorg.wrap problem
3149- ['loginctl','--no-pager list-sessions'],
3150- ['nvidia-settings','-q screens'],
3151- ['nvidia-settings','-c :0.0 -q all'],
3152- ['nvidia-smi','-q'],
3153- ['nvidia-smi','-q -x'],
3154- ['plasmashell','--version'],
3155- ['vainfo',''],
3156- ['vdpauinfo',''],
3157- ['weston-info',''],
3158- ['wmctrl','-m'],
3159- ['weston','--version'],
3160- ['xdpyinfo',''],
3161- ['Xorg','-version'],
3162- ['xprop','-root'],
3163- ['xrandr',''],
3164- );
3165- run_commands(\@cmds,'display');
3166+ my (%data,@files,@files2);
3167+ my $working = '';
3168+ if (!$b_display){
3169+ print "Warning: only some of the data collection can occur if you are not in X\n";
3170+ main::toucher("$data_dir/display-data-warning-user-not-in-x");
3171+ }
3172+ if ($b_root){
3173+ print "Warning: only some of the data collection can occur if you are running as Root user\n";
3174+ main::toucher("$data_dir/display-data-warning-root-user");
3175+ }
3176+ print "Collecting Xorg log and xorg.conf files...\n";
3177+ if (-d "/etc/X11/xorg.conf.d/"){
3178+ @files = main::globber("/etc/X11/xorg.conf.d/*");
3179+ }
3180+ else {
3181+ @files = ('/xorg-conf-d');
3182+ }
3183+ # keep this updated to handle all possible locations we know about for Xorg.0.log
3184+ # not using $system_files{'xorg-log'} for now though it would be best to know what file is used
3185+ main::set_xorg_log();
3186+ push(@files, '/var/log/Xorg.0.log');
3187+ push(@files, '/var/lib/gdm/.local/share/xorg/Xorg.0.log');
3188+ push(@files, $ENV{'HOME'} . '/.local/share/xorg/Xorg.0.log');
3189+ push(@files, $system_files{'xorg-log'}) if $system_files{'xorg-log'};
3190+ push(@files, '/etc/X11/xorg.conf');
3191+ copy_files(\@files,'display-xorg');
3192+ print "Collecting X, xprop, glxinfo, xrandr, xdpyinfo data, wayland, weston...\n";
3193+ %data = (
3194+ 'desktop-session' => $ENV{'DESKTOP_SESSION'},
3195+ 'gdmsession' => $ENV{'GDMSESSION'},
3196+ 'gnome-desktop-session-id' => $ENV{'GNOME_DESKTOP_SESSION_ID'},
3197+ 'kde-full-session' => $ENV{'KDE_FULL_SESSION'},
3198+ 'kde-session-version' => $ENV{'KDE_SESSION_VERSION'},
3199+ 'vdpau-driver' => $ENV{'VDPAU_DRIVER'},
3200+ 'xdg-current-desktop' => $ENV{'XDG_CURRENT_DESKTOP'},
3201+ 'xdg-session-desktop' => $ENV{'XDG_SESSION_DESKTOP'},
3202+ 'xdg-vtnr' => $ENV{'XDG_VTNR'},
3203+ # wayland data collectors:
3204+ 'xdg-session-type' => $ENV{'XDG_SESSION_TYPE'},
3205+ 'wayland-display' => $ENV{'WAYLAND_DISPLAY'},
3206+ 'gdk-backend' => $ENV{'GDK_BACKEND'},
3207+ 'qt-qpa-platform' => $ENV{'QT_QPA_PLATFORM'},
3208+ 'clutter-backend' => $ENV{'CLUTTER_BACKEND'},
3209+ 'sdl-videodriver' => $ENV{'SDL_VIDEODRIVER'},
3210+ # program display values
3211+ 'size-cols-max' => $size{'max'},
3212+ 'size-indent' => $size{'indent'},
3213+ 'size-wrap-width' => $size{'wrap-max'},
3214+ );
3215+ write_data(\%data,'display');
3216+ my @cmds = (
3217+ # kde 5/plasma desktop 5, this is maybe an extra package and won't be used
3218+ ['about-distro',''],
3219+ ['aticonfig','--adapter=all --od-gettemperature'],
3220+ ['glxinfo',''],
3221+ ['glxinfo','-B'],
3222+ ['kded','--version'],
3223+ ['kded1','--version'],
3224+ ['kded2','--version'],
3225+ ['kded3','--version'],
3226+ ['kded4','--version'],
3227+ ['kded5','--version'],
3228+ ['kded6','--version'],
3229+ ['kded7','--version'],
3230+ ['kf-config','--version'],
3231+ ['kf4-config','--version'],
3232+ ['kf5-config','--version'],
3233+ ['kf6-config','--version'],
3234+ ['kf7-config','--version'],
3235+ ['kwin_x11','--version'],
3236+ # ['locate','/Xorg'], # for Xorg.wrap problem
3237+ ['loginctl','--no-pager list-sessions'],
3238+ ['nvidia-settings','-q screens'],
3239+ ['nvidia-settings','-c :0.0 -q all'],
3240+ ['nvidia-smi','-q'],
3241+ ['nvidia-smi','-q -x'],
3242+ ['plasmashell','--version'],
3243+ ['vainfo',''],
3244+ ['vdpauinfo',''],
3245+ ['vulkaninfo',''],
3246+ ['weston-info',''],
3247+ ['wmctrl','-m'],
3248+ ['weston','--version'],
3249+ ['xdpyinfo',''],
3250+ ['Xorg','-version'],
3251+ ['xprop','-root'],
3252+ ['xrandr',''],
3253+ );
3254+ run_commands(\@cmds,'display');
3255 }
3256 sub network_data {
3257- print "Collecting networking data...\n";
3258-# no warnings 'uninitialized';
3259- my @cmds = (
3260- ['ifconfig',''],
3261- ['ip','addr'],
3262- ['ip','-s link'],
3263- );
3264- run_commands(\@cmds,'network');
3265+ print "Collecting networking data...\n";
3266+# no warnings 'uninitialized';
3267+ my @cmds = (
3268+ ['ifconfig',''],
3269+ ['ip','addr'],
3270+ ['ip','-s link'],
3271+ );
3272+ run_commands(\@cmds,'network');
3273 }
3274 sub perl_modules {
3275- print "Collecting Perl module data (this can take a while)...\n";
3276- my @modules = ();
3277- my ($dirname,$holder,$mods,$value) = ('','','','');
3278- my $filename = 'perl-modules.txt';
3279- my @inc;
3280- foreach (sort @INC){
3281- # some BSD installs have '.' n @INC path
3282- if (-d $_ && $_ ne '.'){
3283- $_ =~ s/\/$//; # just in case, trim off trailing slash
3284- $value .= "EXISTS: $_\n";
3285- push @inc, $_;
3286- }
3287- else {
3288- $value .= "ABSENT: $_\n";
3289- }
3290- }
3291- main::writer("$data_dir/perl-inc-data.txt",$value);
3292- File::Find::find { wanted => sub {
3293- push @modules, File::Spec->canonpath($_) if /\.pm\z/
3294- }, no_chdir => 1 }, @inc;
3295- @modules = sort(@modules);
3296- foreach (@modules){
3297- my $dir = $_;
3298- $dir =~ s/[^\/]+$//;
3299- if (!$holder || $holder ne $dir ){
3300- $holder = $dir;
3301- $value = "DIR: $dir\n";
3302- $_ =~ s/^$dir//;
3303- $value .= " $_\n";
3304- }
3305- else {
3306- $value = $_;
3307- $value =~ s/^$dir//;
3308- $value = " $value\n";
3309- }
3310- $mods .= $value;
3311- }
3312- open (my $fh, '>', "$data_dir/$filename");
3313- print $fh $mods;
3314- close $fh;
3315+ print "Collecting Perl module data (this can take a while)...\n";
3316+ my @modules;
3317+ my ($dirname,$holder,$mods,$value) = ('','','','');
3318+ my $filename = 'perl-modules.txt';
3319+ my @inc;
3320+ foreach (sort @INC){
3321+ # some BSD installs have '.' n @INC path
3322+ if (-d $_ && $_ ne '.'){
3323+ $_ =~ s/\/$//; # just in case, trim off trailing slash
3324+ $value .= "EXISTS: $_\n";
3325+ push(@inc, $_);
3326+ }
3327+ else {
3328+ $value .= "ABSENT: $_\n";
3329+ }
3330+ }
3331+ main::writer("$data_dir/perl-inc-data.txt",$value);
3332+ File::Find::find({ wanted => sub {
3333+ push(@modules, File::Spec->canonpath($_)) if /\.pm\z/
3334+ }, no_chdir => 1 }, @inc);
3335+ @modules = sort @modules;
3336+ foreach (@modules){
3337+ my $dir = $_;
3338+ $dir =~ s/[^\/]+$//;
3339+ if (!$holder || $holder ne $dir){
3340+ $holder = $dir;
3341+ $value = "DIR: $dir\n";
3342+ $_ =~ s/^$dir//;
3343+ $value .= " $_\n";
3344+ }
3345+ else {
3346+ $value = $_;
3347+ $value =~ s/^$dir//;
3348+ $value = " $value\n";
3349+ }
3350+ $mods .= $value;
3351+ }
3352+ open(my $fh, '>', "$data_dir/$filename");
3353+ print $fh $mods;
3354+ close $fh;
3355 }
3356 sub system_data {
3357- print "Collecting system data...\n";
3358- my %data = (
3359- 'cc' => $ENV{'CC'},
3360- # @(#)MIRBSD KSH R56 2018/03/09: ksh and mksh
3361- 'ksh-version' => system('echo -n $KSH_VERSION'), # shell, not env, variable
3362- 'manpath' => $ENV{'MANPATH'},
3363- 'path' => $ENV{'PATH'},
3364- 'xdg-config-home' => $ENV{'XDG_CONFIG_HOME'},
3365- 'xdg-config-dirs' => $ENV{'XDG_CONFIG_DIRS'},
3366- 'xdg-data-home' => $ENV{'XDG_DATA_HOME'},
3367- 'xdg-data-dirs' => $ENV{'XDG_DATA_DIRS'},
3368- );
3369- my @files = main::globber('/usr/bin/gcc*');
3370- if (@files){
3371- $data{'gcc-versions'} = join "\n",@files;
3372- }
3373- else {
3374- $data{'gcc-versions'} = undef;
3375- }
3376- @files = main::globber('/sys/*');
3377- if (@files){
3378- $data{'sys-tree-ls-1-basic'} = join "\n", @files;
3379- }
3380- else {
3381- $data{'sys-tree-ls-1-basic'} = undef;
3382- }
3383- write_data(\%data,'system');
3384- # bsd tools http://cb.vu/unixtoolbox.xhtml
3385- my @cmds = (
3386- # general
3387- ['sysctl', '-b kern.geom.conftxt'],
3388- ['sysctl', '-b kern.geom.confxml'],
3389- ['usbdevs','-v'],
3390- # freebsd
3391- ['pciconf','-l -cv'],
3392- ['pciconf','-vl'],
3393- ['pciconf','-l'],
3394- # openbsd
3395- ['pcidump',''],
3396- ['pcidump','-v'],
3397- # netbsd
3398- ['kldstat',''],
3399- ['pcictl','list'],
3400- ['pcictl','list -ns'],
3401- );
3402- run_commands(\@cmds,'system-bsd');
3403- # diskinfo -v <disk>
3404- # fdisk <disk>
3405- @cmds = (
3406- ['clang','--version'],
3407- ['dmidecode',''],
3408- ['dmesg',''],
3409- ['gcc','--version'],
3410- ['hciconfig','-a'],
3411- ['initctl','list'],
3412- ['ipmi-sensors',''],
3413- ['ipmi-sensors','--output-sensor-thresholds'],
3414- ['ipmitool','sensor'],
3415- ['lscpu',''],
3416- ['lspci',''],
3417- ['lspci','-k'],
3418- ['lspci','-n'],
3419- ['lspci','-nn'],
3420- ['lspci','-nnk'],
3421- ['lspci','-nnkv'],# returns ports
3422- ['lspci','-nnv'],
3423- ['lspci','-mm'],
3424- ['lspci','-mmk'],
3425- ['lspci','-mmkv'],
3426- ['lspci','-mmv'],
3427- ['lspci','-mmnn'],
3428- ['lspci','-v'],
3429- ['lsusb',''],
3430- ['lsusb','-t'],
3431- ['lsusb','-v'],
3432- ['ps','aux'],
3433- ['ps','-e'],
3434- ['ps','-p 1'],
3435- ['runlevel',''],
3436- ['rc-status','-a'],
3437- ['rc-status','-l'],
3438- ['rc-status','-r'],
3439- ['sensors',''],
3440- # leaving this commented out to remind that some systems do not
3441- # support strings --version, but will just simply hang at that command
3442- # which you can duplicate by simply typing: strings then hitting enter.
3443- # ['strings','--version'],
3444- ['strings','present'],
3445- ['sysctl','-a'],
3446- ['systemctl','list-units'],
3447- ['systemctl','list-units --type=target'],
3448- ['systemd-detect-virt',''],
3449- ['upower','-e'],
3450- ['uptime',''],
3451- ['vcgencmd','get_mem arm'],
3452- ['vcgencmd','get_mem gpu'],
3453- );
3454- run_commands(\@cmds,'system');
3455- @files = main::globber('/dev/bus/usb/*/*');
3456- copy_files(\@files, 'system');
3457+ print "Collecting system data...\n";
3458+ # has to run here because if null, error, list constructor throws fatal error
3459+ my $ksh = qx(ksh -c 'printf \%s "\$KSH_VERSION"' 2>/dev/null);
3460+ my %data = (
3461+ 'cc' => $ENV{'CC'},
3462+ # @(#)MIRBSD KSH R56 2018/03/09: ksh and mksh
3463+ 'ksh-version' => $ksh, # shell, not env, variable
3464+ 'manpath' => $ENV{'MANPATH'},
3465+ 'path' => $ENV{'PATH'},
3466+ 'xdg-config-home' => $ENV{'XDG_CONFIG_HOME'},
3467+ 'xdg-config-dirs' => $ENV{'XDG_CONFIG_DIRS'},
3468+ 'xdg-data-home' => $ENV{'XDG_DATA_HOME'},
3469+ 'xdg-data-dirs' => $ENV{'XDG_DATA_DIRS'},
3470+ );
3471+ my @files = main::globber('/usr/bin/gcc*');
3472+ if (@files){
3473+ $data{'gcc-versions'} = join("\n", @files);
3474+ }
3475+ else {
3476+ $data{'gcc-versions'} = undef;
3477+ }
3478+ @files = main::globber('/sys/*');
3479+ if (@files){
3480+ $data{'sys-tree-ls-1-basic'} = join("\n", @files);
3481+ }
3482+ else {
3483+ $data{'sys-tree-ls-1-basic'} = undef;
3484+ }
3485+ write_data(\%data,'system');
3486+ # bsd tools http://cb.vu/unixtoolbox.xhtml
3487+ my @cmds = (
3488+ # general
3489+ ['sysctl', '-a'],
3490+ ['sysctl', '-b kern.geom.conftxt'],
3491+ ['sysctl', '-b kern.geom.confxml'],
3492+ ['usbdevs','-v'],
3493+ # freebsd
3494+ ['ofwdump','-a'], # arm / soc
3495+ ['ofwdump','-ar'], # arm / soc
3496+ ['pciconf','-l -cv'],
3497+ ['pciconf','-vl'],
3498+ ['pciconf','-l'],
3499+ ['usbconfig','dump_device_desc'],
3500+ ['usbconfig','list'], # needs root, sigh... why?
3501+ # openbsd
3502+ ['ofctl',''], # arm / soc, need to see data sample of this
3503+ ['pcidump',''],
3504+ ['pcidump','-v'],
3505+ # netbsd
3506+ ['kldstat',''],
3507+ ['pcictl','pci0 list'],
3508+ ['pcictl','pci0 list -N'],
3509+ ['pcictl','pci0 list -n'],
3510+ );
3511+ run_commands(\@cmds,'system-bsd');
3512+ # diskinfo -v <disk>
3513+ # fdisk <disk>
3514+ @cmds = (
3515+ ['clang','--version'],
3516+ # only for prospective ram feature data collection: requires i2c-tools and module eeprom loaded
3517+ ['decode-dimms',''],
3518+ ['dmidecode',''],
3519+ ['dmesg',''],
3520+ ['gcc','--version'],
3521+ ['initctl','list'],
3522+ ['ipmi-sensors',''],
3523+ ['ipmi-sensors','--output-sensor-thresholds'],
3524+ ['ipmitool','sensor'],
3525+ ['lscpu',''],
3526+ ['lspci',''],
3527+ ['lspci','-k'],
3528+ ['lspci','-n'],
3529+ ['lspci','-nn'],
3530+ ['lspci','-nnk'],
3531+ ['lspci','-nnkv'],# returns ports
3532+ ['lspci','-nnv'],
3533+ ['lspci','-mm'],
3534+ ['lspci','-mmk'],
3535+ ['lspci','-mmkv'],
3536+ ['lspci','-mmv'],
3537+ ['lspci','-mmnn'],
3538+ ['lspci','-v'],
3539+ ['lsusb',''],
3540+ ['lsusb','-t'],
3541+ ['lsusb','-v'],
3542+ ['ps','aux'],
3543+ ['ps','-e'],
3544+ ['ps','-p 1'],
3545+ ['runlevel',''],
3546+ ['rc-status','-a'],
3547+ ['rc-status','-l'],
3548+ ['rc-status','-r'],
3549+ ['sensors',''],
3550+ ['sensors','-j'],
3551+ ['sensors','-u'],
3552+ # leaving this commented out to remind that some systems do not
3553+ # support strings --version, but will just simply hang at that command
3554+ # which you can duplicate by simply typing: strings then hitting enter.
3555+ # ['strings','--version'],
3556+ ['strings','present'],
3557+ ['sysctl','-a'],
3558+ ['systemctl','list-units'],
3559+ ['systemctl','list-units --type=target'],
3560+ ['systemd-detect-virt',''],
3561+ ['uname','-a'],
3562+ ['upower','-e'],
3563+ ['uptime',''],
3564+ ['vcgencmd','get_mem arm'],
3565+ ['vcgencmd','get_mem gpu'],
3566+ );
3567+ run_commands(\@cmds,'system');
3568+ @files = main::globber('/dev/bus/usb/*/*');
3569+ copy_files(\@files, 'system');
3570 }
3571 sub system_files {
3572- print "Collecting system files data...\n";
3573- my (%data,@files,@files2);
3574- @files = RepoData::get($data_dir);
3575- copy_files(\@files, 'repo');
3576- # chdir "/etc";
3577- @files = main::globber('/etc/*[-_]{[rR]elease,[vV]ersion,issue}*');
3578- push (@files, '/etc/issue');
3579- push (@files, '/etc/lsb-release');
3580- push (@files, '/etc/os-release');
3581- copy_files(\@files,'system-distro');
3582- @files = main::globber('/etc/upstream[-_]{[rR]elease,[vV]ersion}/*');
3583- copy_files(\@files,'system-distro');
3584- @files = main::globber('/etc/calamares/branding/*/branding.desc');
3585- copy_files(\@files,'system-distro');
3586- @files = (
3587- '/proc/1/comm',
3588- '/proc/cpuinfo',
3589- '/proc/meminfo',
3590- '/proc/modules',
3591- '/proc/net/arp',
3592- '/proc/version',
3593- );
3594- @files2=main::globber('/sys/class/power_supply/*/uevent');
3595- if (@files2){
3596- @files = (@files,@files2);
3597- }
3598- else {
3599- push (@files, '/sys-class-power-supply-empty');
3600- }
3601- copy_files(\@files, 'system');
3602- @files = (
3603- '/etc/make.conf',
3604- '/etc/src.conf',
3605- '/var/run/dmesg.boot',
3606- );
3607- copy_files(\@files,'system-bsd');
3608- @files = main::globber('/sys/devices/system/cpu/vulnerabilities/*');
3609- copy_files(\@files,'security');
3610+ print "Collecting system files data...\n";
3611+ my (%data,@files,@files2);
3612+ @files = RepoItem::get($data_dir);
3613+ copy_files(\@files, 'repo');
3614+ # chdir "/etc";
3615+ @files = main::globber('/etc/*[-_]{[rR]elease,[vV]ersion,issue}*');
3616+ push(@files, '/etc/issue');
3617+ push(@files, '/etc/lsb-release');
3618+ push(@files, '/etc/os-release');
3619+ push(@files, '/system/build.prop');# android data file, requires rooted
3620+ push(@files, '/var/log/installer/oem-id'); # ubuntu only for oem installs?
3621+ copy_files(\@files,'system-distro');
3622+ @files = main::globber('/etc/upstream[-_]{[rR]elease,[vV]ersion}/*');
3623+ copy_files(\@files,'system-distro');
3624+ @files = main::globber('/etc/calamares/branding/*/branding.desc');
3625+ copy_files(\@files,'system-distro');
3626+ @files = (
3627+ '/proc/1/comm',
3628+ '/proc/cmdline',
3629+ '/proc/cpuinfo',
3630+ '/proc/meminfo',
3631+ '/proc/modules',
3632+ '/proc/net/arp',
3633+ '/proc/version',
3634+ );
3635+ @files2=main::globber('/sys/class/power_supply/*/uevent');
3636+ if (@files2){
3637+ push(@files,@files2);
3638+ }
3639+ else {
3640+ push(@files, '/sys-class-power-supply-empty');
3641+ }
3642+ copy_files(\@files, 'system');
3643+ @files = (
3644+ '/etc/make.conf',
3645+ '/etc/src.conf',
3646+ '/var/run/dmesg.boot',
3647+ );
3648+ copy_files(\@files,'system-bsd');
3649+ @files = main::globber('/sys/devices/system/cpu/vulnerabilities/*');
3650+ copy_files(\@files,'security');
3651 }
3652 ## SELF EXECUTE FOR LOG/OUTPUT
3653 sub run_self {
3654- print "Creating $self_name output file now. This can take a few seconds...\n";
3655- print "Starting $self_name from: $self_path\n";
3656- my $i = ($option eq 'main-full')? ' -i' : '';
3657- my $z = ($debugger{'z'}) ? ' -z' : '';
3658- my $iz = "$i$z";
3659- $iz =~ s/[\s\-]//g;
3660- my $cmd = "$self_path/$self_name -FRfrploudmaxxx$i$z --usb --slots --debug 10 -y 120 > $data_dir/$self_name-FRfrploudmaxxx$iz-usb-slots-y120.txt 2>&1";
3661- system($cmd);
3662- copy($log_file, "$data_dir") or main::error_handler('copy-failed', "$log_file", "$!");
3663- system("$self_path/$self_name --recommends -y 120 > $data_dir/$self_name-recommends-120.txt 2>&1");
3664+ print "Creating $self_name output file now. This can take a few seconds...\n";
3665+ print "Starting $self_name from: $self_path\n";
3666+ my $i = ($option eq 'main-full')? ' -i' : '';
3667+ my $z = ($debugger{'filter'}) ? ' -z' : '';
3668+ my $w = ($debugger{'width'}) ? $debugger{'width'} : 120;
3669+ my $iz = "$i$z";
3670+ $iz =~ s/[\s-]//g;
3671+ my $self_file = "$data_dir/$self_name-FERfJLrploudma$iz-slots-y$w.txt";
3672+ my $cmd = "$self_path/$self_name -FERfJLrploudma$i$z --slots --debug 10 -y $w > $self_file 2>&1";
3673+ system($cmd);
3674+ copy($log_file, "$data_dir") or main::error_handler('copy-failed', "$log_file", "$!");
3675+ system("$self_path/$self_name --recommends -y 120 > $data_dir/$self_name-recommends-120.txt 2>&1");
3676 }
3677
3678 ## UTILITIES COPY/CMD/WRITE
3679 sub copy_files {
3680- my ($files_ref,$type,$alt_dir) = @_;
3681- my ($absent,$error,$good,$name,$unreadable);
3682- my $directory = ($alt_dir) ? $alt_dir : $data_dir;
3683- my $working = ($type ne 'proc') ? "$type-file-": '';
3684- foreach (@$files_ref) {
3685- $name = $_;
3686- $name =~ s/^\///;
3687- $name =~ s/\//~/g;
3688- # print "$name\n" if $type eq 'proc';
3689- $name = "$directory/$working$name";
3690- $good = $name . '.txt';
3691- $absent = $name . '-absent';
3692- $error = $name . '-error';
3693- $unreadable = $name . '-unreadable';
3694- # proc have already been tested for readable/exists
3695- if ($type eq 'proc' || -e $_ ) {
3696- print "F:$_\n" if $type eq 'proc' && $debugger{'proc-print'};
3697- if ($type eq 'proc' || -r $_){
3698- copy($_,"$good") or main::toucher($error);
3699- }
3700- else {
3701- main::toucher($unreadable);
3702- }
3703- }
3704- else {
3705- main::toucher($absent);
3706- }
3707- }
3708+ my ($files_ref,$type,$alt_dir) = @_;
3709+ my ($absent,$error,$good,$name,$unreadable);
3710+ my $directory = ($alt_dir) ? $alt_dir : $data_dir;
3711+ my $working = ($type ne 'proc') ? "$type-file-": '';
3712+ foreach (@$files_ref){
3713+ $name = $_;
3714+ $name =~ s/^\///;
3715+ $name =~ s/\//~/g;
3716+ # print "$name\n" if $type eq 'proc';
3717+ $name = "$directory/$working$name";
3718+ $good = $name . '.txt';
3719+ $absent = $name . '-absent';
3720+ $error = $name . '-error';
3721+ $unreadable = $name . '-unreadable';
3722+ # proc have already been tested for readable/exists
3723+ if ($type eq 'proc' || -e $_){
3724+ print "F:$_\n" if $type eq 'proc' && $debugger{'proc-print'};
3725+ if ($type eq 'proc' || -r $_){
3726+ copy($_,"$good") or main::toucher($error);
3727+ }
3728+ else {
3729+ main::toucher($unreadable);
3730+ }
3731+ }
3732+ else {
3733+ main::toucher($absent);
3734+ }
3735+ }
3736 }
3737 sub run_commands {
3738- my ($cmds,$type) = @_;
3739- my $holder = '';
3740- my ($name,$cmd,$args);
3741- foreach (@$cmds){
3742- my @rows = @$_;
3743- if (my $program = main::check_program($rows[0])){
3744- if ($rows[1] eq 'present'){
3745- $name = "$data_dir/$type-cmd-$rows[0]-present";
3746- main::toucher($name);
3747- }
3748- else {
3749- $args = $rows[1];
3750- $args =~ s/\s|--|\/|=/-/g; # for:
3751- $args =~ s/--/-/g;# strip out -- that result from the above
3752- $args =~ s/^-//g;
3753- $args = "-$args" if $args;
3754- $name = "$data_dir/$type-cmd-$rows[0]$args.txt";
3755- $cmd = "$program $rows[1] >$name 2>&1";
3756- system($cmd);
3757- }
3758- }
3759- else {
3760- if ($holder ne $rows[0]){
3761- $name = "$data_dir/$type-cmd-$rows[0]-absent";
3762- main::toucher($name);
3763- $holder = $rows[0];
3764- }
3765- }
3766- }
3767+ my ($cmds,$type) = @_;
3768+ my $holder = '';
3769+ my ($name,$cmd,$args);
3770+ foreach my $rows (@$cmds){
3771+ if (my $program = main::check_program($rows->[0])){
3772+ if ($rows->[1] eq 'present'){
3773+ $name = "$data_dir/$type-cmd-$rows->[0]-present";
3774+ main::toucher($name);
3775+ }
3776+ else {
3777+ $args = $rows->[1];
3778+ $args =~ s/\s|--|\/|=/-/g; # for:
3779+ $args =~ s/--/-/g;# strip out -- that result from the above
3780+ $args =~ s/^-//g;
3781+ $args = "-$args" if $args;
3782+ $name = "$data_dir/$type-cmd-$rows->[0]$args.txt";
3783+ $cmd = "$program $rows->[1] >$name 2>&1";
3784+ system($cmd);
3785+ }
3786+ }
3787+ else {
3788+ if ($holder ne $rows->[0]){
3789+ $name = "$data_dir/$type-cmd-$rows->[0]-absent";
3790+ main::toucher($name);
3791+ $holder = $rows->[0];
3792+ }
3793+ }
3794+ }
3795 }
3796 sub write_data {
3797- my ($data_ref, $type) = @_;
3798- my ($empty,$error,$fh,$good,$name,$undefined,$value);
3799- foreach (keys %$data_ref) {
3800- $value = $$data_ref{$_};
3801- $name = "$data_dir/$type-data-$_";
3802- $good = $name . '.txt';
3803- $empty = $name . '-empty';
3804- $error = $name . '-error';
3805- $undefined = $name . '-undefined';
3806- if (defined $value) {
3807- if ($value || $value eq '0'){
3808- open($fh, '>', $good) or main::toucher($error);
3809- print $fh "$value";
3810- }
3811- else {
3812- main::toucher($empty);
3813- }
3814- }
3815- else {
3816- main::toucher($undefined);
3817- }
3818- }
3819+ my ($data_ref, $type) = @_;
3820+ my ($empty,$error,$fh,$good,$name,$undefined,$value);
3821+ foreach (keys %$data_ref){
3822+ $value = $data_ref->{$_};
3823+ $name = "$data_dir/$type-data-$_";
3824+ $good = $name . '.txt';
3825+ $empty = $name . '-empty';
3826+ $error = $name . '-error';
3827+ $undefined = $name . '-undefined';
3828+ if (defined $value){
3829+ if ($value || $value eq '0'){
3830+ open($fh, '>', $good) or main::toucher($error);
3831+ print $fh "$value";
3832+ }
3833+ else {
3834+ main::toucher($empty);
3835+ }
3836+ }
3837+ else {
3838+ main::toucher($undefined);
3839+ }
3840+ }
3841 }
3842 ## TOOLS FOR DIRECTORY TREE/LS/TRAVERSE; UPLOADER
3843 sub build_tree {
3844- my ($which) = @_;
3845- if ( $which eq 'sys' && main::check_program('tree') ){
3846- print "Constructing /$which tree data...\n";
3847- my $dirname = '/sys';
3848- my $cmd;
3849- system("tree -a -L 10 /sys > $data_dir/sys-data-tree-full-10.txt");
3850- opendir my($dh), $dirname or main::error_handler('open-dir',"$dirname", "$!");
3851- my @files = readdir $dh;
3852- closedir $dh;
3853- foreach (@files){
3854- next if /^\./;
3855- $cmd = "tree -a -L 10 $dirname/$_ > $data_dir/sys-data-tree-$_-10.txt";
3856- #print "$cmd\n";
3857- system($cmd);
3858- }
3859- }
3860- print "Constructing /$which ls data...\n";
3861- if ($which eq 'sys'){
3862- directory_ls($which,1);
3863- directory_ls($which,2);
3864- directory_ls($which,3);
3865- directory_ls($which,4);
3866- }
3867- elsif ($which eq 'proc') {
3868- directory_ls('proc',1);
3869- directory_ls('proc',2,'[a-z]');
3870- # don't want the /proc/self or /proc/thread-self directories, those are
3871- # too invasive
3872- #directory_ls('proc',3,'[a-z]');
3873- #directory_ls('proc',4,'[a-z]');
3874- }
3875+ my ($which) = @_;
3876+ if ($which eq 'sys' && main::check_program('tree')){
3877+ print "Constructing /$which tree data...\n";
3878+ my $dirname = '/sys';
3879+ my $cmd;
3880+ system("tree -a -L 10 /sys > $data_dir/sys-data-tree-full-10.txt");
3881+ opendir(my $dh, $dirname) or main::error_handler('open-dir',"$dirname", "$!");
3882+ my @files = readdir($dh);
3883+ closedir $dh;
3884+ foreach (@files){
3885+ next if /^\./;
3886+ $cmd = "tree -a -L 10 $dirname/$_ > $data_dir/sys-data-tree-$_-10.txt";
3887+ # print "$cmd\n";
3888+ system($cmd);
3889+ }
3890+ }
3891+ print "Constructing /$which ls data...\n";
3892+ if ($which eq 'sys'){
3893+ directory_ls($which,1);
3894+ directory_ls($which,2);
3895+ directory_ls($which,3);
3896+ directory_ls($which,4);
3897+ }
3898+ elsif ($which eq 'proc'){
3899+ directory_ls('proc',1);
3900+ directory_ls('proc',2,'[a-z]');
3901+ # don't want the /proc/self or /proc/thread-self directories, those are
3902+ # too invasive
3903+ #directory_ls('proc',3,'[a-z]');
3904+ #directory_ls('proc',4,'[a-z]');
3905+ }
3906 }
3907
3908 # include is basic regex for ls path syntax, like [a-z]
3909 sub directory_ls {
3910- my ( $dir,$depth,$include) = @_;
3911- $include ||= '';
3912- my ($exclude) = ('');
3913- # wd do NOT want to see anything in self or thread-self!!
3914- # $exclude = 'I self -I thread-self' if $dir eq 'proc';
3915- my $cmd = do {
3916- if ( $depth == 1 ){ "ls -l $exclude /$dir/$include 2>/dev/null" }
3917- elsif ( $depth == 2 ){ "ls -l $exclude /$dir/$include*/ 2>/dev/null" }
3918- elsif ( $depth == 3 ){ "ls -l $exclude /$dir/$include*/*/ 2>/dev/null" }
3919- elsif ( $depth == 4 ){ "ls -l $exclude /$dir/$include*/*/*/ 2>/dev/null" }
3920- elsif ( $depth == 5 ){ "ls -l $exclude /$dir/$include*/*/*/*/ 2>/dev/null" }
3921- elsif ( $depth == 6 ){ "ls -l $exclude /$dir/$include*/*/*/*/*/ 2>/dev/null" }
3922- };
3923- my @working = ();
3924- my $output = '';
3925- my ($type);
3926- my $result = qx($cmd);
3927- open my $ch, '<', \$result or main::error_handler('open-data',"$cmd", "$!");
3928- while ( my $line = <$ch> ){
3929- chomp($line);
3930- $line =~ s/^\s+|\s+$//g;
3931- @working = split /\s+/, $line;
3932- $working[0] ||= '';
3933- if ( scalar @working > 7 ){
3934- if ($working[0] =~ /^d/ ){
3935- $type = "d - ";
3936- }
3937- elsif ($working[0] =~ /^l/){
3938- $type = "l - ";
3939- }
3940- else {
3941- $type = "f - ";
3942- }
3943- $working[9] ||= '';
3944- $working[10] ||= '';
3945- $output = $output . " $type$working[8] $working[9] $working[10]\n";
3946- }
3947- elsif ( $working[0] !~ /^total/ ){
3948- $output = $output . $line . "\n";
3949- }
3950- }
3951- close $ch;
3952- my $file = "$data_dir/$dir-data-ls-$depth.txt";
3953- open my $fh, '>', $file or main::error_handler('create',"$file", "$!");
3954- print $fh $output;
3955- close $fh;
3956- # print "$output\n";
3957+ my ($dir,$depth,$include) = @_;
3958+ $include ||= '';
3959+ my ($exclude) = ('');
3960+ # wd do NOT want to see anything in self or thread-self!!
3961+ # $exclude = 'I self -I thread-self' if $dir eq 'proc';
3962+ my $cmd = do {
3963+ if ($depth == 1){ "ls -l $exclude /$dir/$include 2>/dev/null" }
3964+ elsif ($depth == 2){ "ls -l $exclude /$dir/$include*/ 2>/dev/null" }
3965+ elsif ($depth == 3){ "ls -l $exclude /$dir/$include*/*/ 2>/dev/null" }
3966+ elsif ($depth == 4){ "ls -l $exclude /$dir/$include*/*/*/ 2>/dev/null" }
3967+ elsif ($depth == 5){ "ls -l $exclude /$dir/$include*/*/*/*/ 2>/dev/null" }
3968+ elsif ($depth == 6){ "ls -l $exclude /$dir/$include*/*/*/*/*/ 2>/dev/null" }
3969+ };
3970+ my @working;
3971+ my $output = '';
3972+ my ($type);
3973+ my $result = qx($cmd);
3974+ open(my $ch, '<', \$result) or main::error_handler('open-data',"$cmd", "$!");
3975+ while (my $line = <$ch>){
3976+ chomp($line);
3977+ $line =~ s/^\s+|\s+$//g;
3978+ @working = split(/\s+/, $line);
3979+ $working[0] ||= '';
3980+ if (scalar @working > 7){
3981+ if ($working[0] =~ /^d/){
3982+ $type = "d - ";
3983+ }
3984+ elsif ($working[0] =~ /^l/){
3985+ $type = "l - ";
3986+ }
3987+ else {
3988+ $type = "f - ";
3989+ }
3990+ $working[9] ||= '';
3991+ $working[10] ||= '';
3992+ $output = $output . " $type$working[8] $working[9] $working[10]\n";
3993+ }
3994+ elsif ($working[0] !~ /^total/){
3995+ $output = $output . $line . "\n";
3996+ }
3997+ }
3998+ close $ch;
3999+ my $file = "$data_dir/$dir-data-ls-$depth.txt";
4000+ open(my $fh, '>', $file) or main::error_handler('create',"$file", "$!");
4001+ print $fh $output;
4002+ close $fh;
4003+ # print "$output\n";
4004 }
4005 sub proc_traverse_data {
4006- print "Building /proc file list...\n";
4007- # get rid pointless error:Can't cd to (/sys/kernel/) debug: Permission denied
4008- no warnings 'File::Find';
4009- $parse_src = 'proc';
4010- File::Find::find( \&wanted, "/proc");
4011- proc_traverse_processor();
4012- @content = ();
4013-}
4014-sub proc_traverse_processor {
4015- my ($data,$fh,$result,$row,$sep);
4016- my $proc_dir = "$data_dir/proc";
4017- print "Adding /proc files...\n";
4018- mkdir $proc_dir or main::error_handler('mkdir', "$proc_dir", "$!");
4019- # @content = sort @content;
4020- copy_files(\@content,'proc',$proc_dir);
4021-# foreach (@content){
4022-# print "$_\n";
4023-# }
4024+ print "Building /proc file list...\n";
4025+ # get rid pointless error:Can't cd to (/sys/kernel/) debug: Permission denied
4026+ #no warnings 'File::Find';
4027+ no warnings;
4028+ $parse_src = 'proc';
4029+ File::Find::find(\&wanted, "/proc");
4030+ process_proc_traverse();
4031+ @content = ();
4032+}
4033+sub process_proc_traverse {
4034+ my ($data,$fh,$result,$row,$sep);
4035+ my $proc_dir = "$data_dir/proc";
4036+ print "Adding /proc files...\n";
4037+ mkdir $proc_dir or main::error_handler('mkdir', "$proc_dir", "$!");
4038+ # @content = sort @content;
4039+ copy_files(\@content,'proc',$proc_dir);
4040+# foreach (@content){print "$_\n";}
4041 }
4042
4043 sub sys_traverse_data {
4044- print "Building /sys file list...\n";
4045- # get rid pointless error:Can't cd to (/sys/kernel/) debug: Permission denied
4046- no warnings 'File::Find';
4047- $parse_src = 'sys';
4048- File::Find::find( \&wanted, "/sys");
4049- sys_traverse_processsor();
4050- @content = ();
4051-}
4052-sub sys_traverse_processsor {
4053- my ($data,$fh,$result,$row,$sep);
4054- my $filename = "sys-data-parse.txt";
4055- print "Parsing /sys files...\n";
4056- # no sorts, we want the order it comes in
4057- # @content = sort @content;
4058- foreach (@content){
4059- $data='';
4060- $sep='';
4061- my $b_fh = 1;
4062- print "F:$_\n" if $debugger{'sys-print'};
4063- open($fh, '<', $_) or $b_fh = 0;
4064- # needed for removing -T test and root
4065- if ($b_fh){
4066- while ($row = <$fh>) {
4067- chomp $row;
4068- $data .= $sep . '"' . $row . '"';
4069- $sep=', ';
4070- }
4071- }
4072- else {
4073- $data = '<unreadable>';
4074- }
4075- $result .= "$_:[$data]\n";
4076- # print "$_:[$data]\n"
4077- }
4078- # print scalar @content . "\n";
4079- open ($fh, '>', "$data_dir/$filename");
4080- print $fh $result;
4081- close $fh;
4082- # print $fh "$result";
4083-}
4084-
4085+ print "Building /sys file list...\n";
4086+ # get rid pointless error:Can't cd to (/sys/kernel/) debug: Permission denied
4087+ #no warnings 'File::Find';
4088+ no warnings;
4089+ $parse_src = 'sys';
4090+ File::Find::find(\&wanted, "/sys");
4091+ process_sys_traverse();
4092+ @content = ();
4093+}
4094+sub process_sys_traverse {
4095+ my ($data,$fh,$result,$row,$sep);
4096+ my $filename = "sys-data-parse.txt";
4097+ print "Parsing /sys files...\n";
4098+ # no sorts, we want the order it comes in
4099+ # @content = sort @content;
4100+ foreach (@content){
4101+ $data='';
4102+ $sep='';
4103+ my $b_fh = 1;
4104+ print "F:$_\n" if $debugger{'sys-print'};
4105+ open($fh, '<', $_) or $b_fh = 0;
4106+ # needed for removing -T test and root
4107+ if ($b_fh){
4108+ while ($row = <$fh>){
4109+ chomp($row);
4110+ $data .= $sep . '"' . $row . '"';
4111+ $sep=', ';
4112+ }
4113+ }
4114+ else {
4115+ $data = '<unreadable>';
4116+ }
4117+ $result .= "$_:[$data]\n";
4118+ # print "$_:[$data]\n"
4119+ }
4120+ # print scalar @content . "\n";
4121+ open($fh, '>', "$data_dir/$filename");
4122+ print $fh $result;
4123+ close $fh;
4124+ # print $fh "$result";
4125+}
4126+# perl compiler complains on start if prune = 1 used only once, so either
4127+# do $File::Find::prune = 1 if !$File::Find::prune; OR use no warnings 'once'
4128 sub wanted {
4129- return if -d; # not directory
4130- return unless -e; # Must exist
4131- return unless -f; # Must be file
4132- return unless -r; # Must be readable
4133- if ($parse_src eq 'sys'){
4134- # note: a new file in 4.11 /sys can hang this, it is /parameter/ then
4135- # a few variables. Since inxi does not need to see that file, we will
4136- # not use it. Also do not need . files or __ starting files
4137- # print $File::Find::name . "\n";
4138- # block maybe: cfgroup\/
4139- # picdec\/|, wait_for_fb_sleep/wake is an odroid thing caused hang
4140- return if $File::Find::name =~ /(^\/sys\/power\/wait_for_fb)/;
4141- return if $File::Find::name =~ /\/(\.[a-z]|kernel\/|trace\/|parameters\/|debug\/)/;
4142- # comment this one out if you experience hangs or if
4143- # we discover syntax of foreign language characters
4144- # Must be ascii like. This is questionable and might require further
4145- # investigation, it is removing some characters that we might want
4146- # NOTE: this made a bunch of files on arm systems unreadable so we handle
4147- # the readable tests in copy_files()
4148- # return unless -T;
4149- }
4150- elsif ($parse_src eq 'proc') {
4151- return if $File::Find::name =~ /^\/proc\/[0-9]+\//;
4152- return if $File::Find::name =~ /^\/proc\/bus\/pci\//;
4153- return if $File::Find::name =~ /^\/proc\/(irq|spl|sys)\//;
4154- # these choke on sudo/root: kmsg kcore kpage and we don't want keys or kallsyms
4155- return if $File::Find::name =~ /^\/proc\/k/;
4156- return if $File::Find::name =~ /(\/mb_groups|debug)$/;
4157- }
4158- # print $File::Find::name . "\n";
4159- push (@content, $File::Find::name);
4160- return;
4161+ # note: we want these directories pruned before the -d test so find
4162+ # doesn't try to read files inside of the directories
4163+ if ($parse_src eq 'proc'){
4164+ if ($File::Find::name =~ m!^/proc/[0-9]+! ||
4165+ $File::Find::name =~ m!^/proc/(irq|spl|sys)! ||
4166+ # these choke on sudo/root: kmsg kcore kpage and we don't want keys or kallsyms
4167+ $File::Find::name =~ m!^/proc/k! ||
4168+ $File::Find::name =~ m!^/proc/bus/pci! ||
4169+ $File::Find::name =~ m!^/proc/(irq|spl|sys)!){
4170+ $File::Find::prune = 1;
4171+ return;
4172+ }
4173+ }
4174+ elsif ($parse_src eq 'sys'){
4175+ # note: a new file in 4.11 /sys can hang this, it is /parameter/ then
4176+ # a few variables. Since inxi does not need to see that file, we will
4177+ # not use it.
4178+ if ($File::Find::name =~ m!/(kernel/|trace/|parameters|debug)!){
4179+ $File::Find::prune = 1;
4180+ }
4181+ }
4182+ return if -d; # not directory
4183+ return unless -e; # Must exist
4184+ return unless -f; # Must be file
4185+ return unless -r; # Must be readable
4186+ if ($parse_src eq 'sys'){
4187+ # print $File::Find::name . "\n";
4188+ # block maybe: cfgroup\/
4189+ # picdec\/|, wait_for_fb_sleep/wake is an odroid thing caused hang
4190+ # wakeup_count also fails for android, but works fine on regular systems
4191+ return if $b_arm && $File::Find::name =~ m!^/sys/power/(wait_for_fb_|wakeup_count$)!;
4192+ # do not need . files or __ starting files
4193+ return if $File::Find::name =~ m!/\.[a-z]!;
4194+ # pp_num_states: amdgpu driver bug; android: wakeup_count
4195+ return if $File::Find::name =~ m!/pp_num_states$!;
4196+ # comment this one out if you experience hangs or if
4197+ # we discover syntax of foreign language characters
4198+ # Must be ascii like. This is questionable and might require further
4199+ # investigation, it is removing some characters that we might want
4200+ # NOTE: this made a bunch of files on arm systems unreadable so we handle
4201+ # the readable tests in copy_files()
4202+ # return unless -T;
4203+ }
4204+ elsif ($parse_src eq 'proc'){
4205+ return if $File::Find::name =~ m!(/mb_groups|debug)$!;
4206+ }
4207+ # print $File::Find::name . "\n";
4208+ push(@content, $File::Find::name);
4209+ return;
4210 }
4211 # args: 1 - path to file to be uploaded
4212 # args: 2 - optional: alternate ftp upload url
4213 # NOTE: must be in format: ftp.site.com/incoming
4214 sub upload_file {
4215- require Net::FTP;
4216- import Net::FTP;
4217- my ($self, $ftp_url) = @_;
4218- my ($ftp, $domain, $host, $user, $pass, $dir, $error);
4219- $ftp_url ||= main::get_defaults('ftp-upload');
4220- $ftp_url =~ s/\/$//g; # trim off trailing slash if present
4221- my @url = split(/\//, $ftp_url);
4222- my $file_path = "$user_data_dir/$debug_gz";
4223- $host = $url[0];
4224- $dir = $url[1];
4225- $domain = $host;
4226- $domain =~ s/^ftp\.//;
4227- $user = "anonymous";
4228- $pass = "anonymous\@$domain";
4229-
4230- print $line3;
4231- print "Uploading to: $ftp_url\n";
4232- # print "$host $domain $dir $user $pass\n";
4233- print "File to be uploaded:\n$file_path\n";
4234-
4235- if ($host && ( $file_path && -e $file_path ) ){
4236- # NOTE: important: must explicitly set to passive true/1
4237- $ftp = Net::FTP->new($host, Debug => 0, Passive => 1) || main::error_handler('ftp-connect', $ftp->message);
4238- $ftp->login($user, $pass) || main::error_handler('ftp-login', $ftp->message);
4239- $ftp->binary();
4240- $ftp->cwd($dir);
4241- print "Connected to FTP server.\n";
4242- $ftp->put($file_path) || main::error_handler('ftp-upload', $ftp->message);
4243- $ftp->quit;
4244- print "Uploaded file successfully!\n";
4245- print $ftp->message;
4246- if ($debugger{'gz'}){
4247- print "Removing debugger gz file:\n$file_path\n";
4248- unlink $file_path or main::error_handler('remove',"$file_path", "$!");
4249- print "File removed.\n";
4250- }
4251- print "Debugger data generation and upload completed. Thank you for your help.\n";
4252- }
4253- else {
4254- main::error_handler('ftp-bad-path', "$file_path");
4255- }
4256+ my ($self, $ftp_url) = @_;
4257+ my ($ftp, $domain, $host, $user, $pass, $dir, $error);
4258+ $ftp_url ||= main::get_defaults('ftp-upload');
4259+ $ftp_url =~ s/\/$//g; # trim off trailing slash if present
4260+ my @url = split('/', $ftp_url);
4261+ my $file_path = "$user_data_dir/$debug_gz";
4262+ $host = $url[0];
4263+ $dir = $url[1];
4264+ $domain = $host;
4265+ $domain =~ s/^ftp\.//;
4266+ $user = "anonymous";
4267+ $pass = "anonymous\@$domain";
4268+
4269+ print $line3;
4270+ print "Uploading to: $ftp_url\n";
4271+ # print "$host $domain $dir $user $pass\n";
4272+ print "File to be uploaded:\n$file_path\n";
4273+
4274+ if ($host && ($file_path && -e $file_path)){
4275+ # NOTE: important: must explicitly set to passive true/1
4276+ $ftp = Net::FTP->new($host, Debug => 0, Passive => 1) || main::error_handler('ftp-connect', $ftp->message);
4277+ $ftp->login($user, $pass) || main::error_handler('ftp-login', $ftp->message);
4278+ $ftp->binary();
4279+ $ftp->cwd($dir);
4280+ print "Connected to FTP server.\n";
4281+ $ftp->put($file_path) || main::error_handler('ftp-upload', $ftp->message);
4282+ $ftp->quit;
4283+ print "Uploaded file successfully!\n";
4284+ print $ftp->message;
4285+ if ($debugger{'gz'}){
4286+ print "Removing debugger gz file:\n$file_path\n";
4287+ unlink $file_path or main::error_handler('remove',"$file_path", "$!");
4288+ print "File removed.\n";
4289+ }
4290+ print "Debugger data generation and upload completed. Thank you for your help.\n";
4291+ }
4292+ else {
4293+ main::error_handler('ftp-bad-path', "$file_path");
4294+ }
4295 }
4296 }
4297+
4298 # random tests for various issues
4299 sub user_debug_test_1 {
4300-# open(my $duped, '>&', STDOUT);
4301-# local *STDOUT = $duped;
4302-# my $item = POSIX::strftime("%c", localtime);
4303-# print "Testing character encoding handling. Perl IO data:\n";
4304-# print(join(', ', PerlIO::get_layers(STDOUT)), "\n");
4305-# print "Without binmode: ", $item,"\n";
4306-# binmode STDOUT,":utf8";
4307-# print "With binmode: ", $item,"\n";
4308-# print "Perl IO data:\n";
4309-# print(join(', ', PerlIO::get_layers(STDOUT)), "\n");
4310-# close($duped);
4311+# open(my $duped, '>&', STDOUT);
4312+# local *STDOUT = $duped;
4313+# my $item = POSIX::strftime("%c", localtime);
4314+# print "Testing character encoding handling. Perl IO data:\n";
4315+# print(join(', ', PerlIO::get_layers(STDOUT)), "\n");
4316+# print "Without binmode: ", $item,"\n";
4317+# binmode STDOUT,":utf8";
4318+# print "With binmode: ", $item,"\n";
4319+# print "Perl IO data:\n";
4320+# print(join(', ', PerlIO::get_layers(STDOUT)), "\n");
4321+# close $duped;
4322+}
4323+
4324+# see docs/optimization.txt
4325+sub ram_use {
4326+ my ($name, $ref) = @_;
4327+ printf "%-25s %5d %5d\n", $name, size($ref), total_size($ref);
4328 }
4329
4330 #### -------------------------------------------------------------------
4331@@ -2152,165 +2461,177 @@ sub user_debug_test_1 {
4332 #### -------------------------------------------------------------------
4333
4334 sub download_file {
4335- my ($type, $url, $file) = @_;
4336- my ($cmd,$args,$timeout) = ('','','');
4337- my $debug_data = '';
4338- my $result = 1;
4339- $dl{'no-ssl-opt'} ||= '';
4340- $dl{'spider'} ||= '';
4341- $file ||= 'N/A'; # to avoid debug error
4342- if ( ! $dl{'dl'} ){
4343- return 0;
4344- }
4345- if ($dl{'timeout'}){
4346- $timeout = "$dl{'timeout'}$dl_timeout";
4347- }
4348- # print "$dl{'no-ssl-opt'}\n";
4349- # print "$dl{'dl'}\n";
4350- # tiny supports spider sort of
4351- ## NOTE: 1 is success, 0 false for Perl
4352- if ($dl{'dl'} eq 'tiny' ){
4353- $cmd = "Using tiny: type: $type \nurl: $url \nfile: $file";
4354- $result = get_file($type, $url, $file);
4355- $debug_data = ($type ne 'stdout') ? $result : 'Success: stdout data not null.';
4356- }
4357- # But: 0 is success, and 1 is false for these
4358- # when strings are returned, they will be taken as true
4359- else {
4360- if ($type eq 'stdout'){
4361- $args = $dl{'stdout'};
4362- $cmd = "$dl{'dl'} $dl{'no-ssl-opt'} $timeout $args $url $dl{'null'}";
4363- $result = qx($cmd);
4364- $debug_data = ($result) ? 'Success: stdout data not null.' : 'Download resulted in null data!';
4365- }
4366- elsif ($type eq 'file') {
4367- $args = $dl{'file'};
4368- $cmd = "$dl{'dl'} $dl{'no-ssl-opt'} $timeout $args $file $url $dl{'null'}";
4369- system($cmd);
4370- $result = ($?) ? 0 : 1; # reverse these into Perl t/f
4371- $debug_data = $result;
4372- }
4373- elsif ( $dl{'dl'} eq 'wget' && $type eq 'spider'){
4374- $cmd = "$dl{'dl'} $dl{'no-ssl-opt'} $timeout $dl{'spider'} $url";
4375- system($cmd);
4376- $result = ($?) ? 0 : 1; # reverse these into Perl t/f
4377- $debug_data = $result;
4378- }
4379- }
4380- print "-------\nDownloader Data:\n$cmd\nResult: $debug_data\n" if $test[1];
4381- log_data('data',"$cmd\nResult: $result") if $b_log;
4382- return $result;
4383+ my ($type, $url, $file,$ua) = @_;
4384+ my ($cmd,$args,$timeout) = ('','','');
4385+ my $debug_data = '';
4386+ my $result = 1;
4387+ $ua = ($ua && $dl{'ua'}) ? $dl{'ua'} . $ua : '';
4388+ $dl{'no-ssl-opt'} ||= '';
4389+ $dl{'spider'} ||= '';
4390+ $file ||= 'N/A'; # to avoid debug error
4391+ if (!$dl{'dl'}){
4392+ return 0;
4393+ }
4394+ if ($dl{'timeout'}){
4395+ $timeout = "$dl{'timeout'}$dl_timeout";
4396+ }
4397+ # print "$dl{'no-ssl-opt'}\n";
4398+ # print "$dl{'dl'}\n";
4399+ # tiny supports spider sort of
4400+ ## NOTE: 1 is success, 0 false for Perl
4401+ if ($dl{'dl'} eq 'tiny'){
4402+ $cmd = "Using tiny: type: $type \nurl: $url \nfile: $file";
4403+ $result = get_file($type, $url, $file);
4404+ $debug_data = ($type ne 'stdout') ? $result : 'Success: stdout data not null.';
4405+ }
4406+ # But: 0 is success, and 1 is false for these
4407+ # when strings are returned, they will be taken as true
4408+ # urls must be " quoted in case special characters present
4409+ else {
4410+ if ($type eq 'stdout'){
4411+ $args = $dl{'stdout'};
4412+ $cmd = "$dl{'dl'} $dl{'no-ssl-opt'} $ua $timeout $args \"$url\" $dl{'null'}";
4413+ $result = qx($cmd);
4414+ $debug_data = ($result) ? 'Success: stdout data not null.' : 'Download resulted in null data!';
4415+ }
4416+ elsif ($type eq 'file'){
4417+ $args = $dl{'file'};
4418+ $cmd = "$dl{'dl'} $dl{'no-ssl-opt'} $ua $timeout $args $file \"$url\" $dl{'null'}";
4419+ system($cmd);
4420+ $result = ($?) ? 0 : 1; # reverse these into Perl t/f
4421+ $debug_data = $result;
4422+ }
4423+ elsif ($dl{'dl'} eq 'wget' && $type eq 'spider'){
4424+ $cmd = "$dl{'dl'} $dl{'no-ssl-opt'} $ua $timeout $dl{'spider'} \"$url\"";
4425+ system($cmd);
4426+ $result = ($?) ? 0 : 1; # reverse these into Perl t/f
4427+ $debug_data = $result;
4428+ }
4429+ }
4430+ print "-------\nDownloader Data:\n$cmd\nResult: $debug_data\n" if $dbg[1];
4431+ log_data('data',"$cmd\nResult: $result") if $b_log;
4432+ return $result;
4433 }
4434
4435 sub get_file {
4436- my ($type, $url, $file) = @_;
4437- my $response = HTTP::Tiny->new->get($url);
4438- my $return = 1;
4439- my $debug = 0;
4440- my $fh;
4441- $file ||= 'N/A';
4442- log_data('dump','%{$response}',\%{$response}) if $b_log;
4443- # print Dumper \%{$response};
4444- if ( ! $response->{success} ){
4445- my $content = $response->{content};
4446- $content ||= "N/A\n";
4447- my $msg = "Failed to connect to server/file!\n";
4448- $msg .= "Response: ${content}Downloader: HTTP::Tiny URL: $url\nFile: $file";
4449- log_data('data',$msg) if $b_log;
4450- print error_defaults('download-error',$msg) if $test[1];
4451- $return = 0;
4452- }
4453- else {
4454- if ( $debug ){
4455- print "$response->{success}\n";
4456- print "$response->{status} $response->{reason}\n";
4457- while (my ($key, $value) = each %{$response->{headers}}) {
4458- for (ref $value eq "ARRAY" ? @$value : $value) {
4459- print "$key: $_\n";
4460- }
4461- }
4462- }
4463- if ( $type eq "stdout" || $type eq "ua-stdout" ){
4464- $return = $response->{content};
4465- }
4466- elsif ($type eq "spider"){
4467- # do nothing, just use the return value
4468- }
4469- elsif ($type eq "file"){
4470- open($fh, ">", $file);
4471- print $fh $response->{content}; # or die "can't write to file!\n";
4472- close $fh;
4473- }
4474- }
4475- return $return;
4476+ my ($type, $url, $file) = @_;
4477+ my $tiny = HTTP::Tiny->new;
4478+ # note: default is no verify, so default here actually is to verify unless overridden
4479+ $tiny->verify_SSL => 1 if !$dl{'no-ssl-opt'};
4480+ my $response = $tiny->get($url);
4481+ my $return = 1;
4482+ my $debug = 0;
4483+ my $fh;
4484+ $file ||= 'N/A';
4485+ log_data('dump','%{$response}',$response) if $b_log;
4486+ # print Dumper $response;
4487+ if (!$response->{'success'}){
4488+ my $content = $response->{'content'};
4489+ $content ||= "N/A\n";
4490+ my $msg = "Failed to connect to server/file!\n";
4491+ $msg .= "Response: ${content}Downloader: HTTP::Tiny URL: $url\nFile: $file";
4492+ log_data('data',$msg) if $b_log;
4493+ print error_defaults('download-error',$msg) if $dbg[1];
4494+ $return = 0;
4495+ }
4496+ else {
4497+ if ($debug){
4498+ print "$response->{success}\n";
4499+ print "$response->{status} $response->{reason}\n";
4500+ while (my ($key, $value) = each %{$response->{'headers'}}){
4501+ for (ref $value eq "ARRAY" ? @$value : $value){
4502+ print "$key: $_\n";
4503+ }
4504+ }
4505+ }
4506+ if ($type eq "stdout" || $type eq "ua-stdout"){
4507+ $return = $response->{'content'};
4508+ }
4509+ elsif ($type eq "spider"){
4510+ # do nothing, just use the return value
4511+ }
4512+ elsif ($type eq "file"){
4513+ open($fh, ">", $file);
4514+ print $fh $response->{'content'}; # or die "can't write to file!\n";
4515+ close $fh;
4516+ }
4517+ }
4518+ return $return;
4519 }
4520
4521 sub set_downloader {
4522- eval $start if $b_log;
4523- $dl{'no-ssl'} = '';
4524- $dl{'null'} = '';
4525- $dl{'spider'} = '';
4526- # we only want to use HTTP::Tiny if it's present in user system.
4527- # It is NOT part of core modules. IO::Socket::SSL is also required
4528- # For some https connections so only use tiny as option if both present
4529- if ($dl{'tiny'}){
4530- if (check_module('HTTP::Tiny') && check_module('IO::Socket::SSL')){
4531- import HTTP::Tiny;
4532- import IO::Socket::SSL;
4533- $dl{'tiny'} = 1;
4534- }
4535- else {
4536- $dl{'tiny'} = 0;
4537- }
4538- }
4539- #print $dl{'tiny'} . "\n";
4540- if ($dl{'tiny'}){
4541- $dl{'dl'} = 'tiny';
4542- $dl{'file'} = '';
4543- $dl{'stdout'} = '';
4544- $dl{'timeout'} = '';
4545- }
4546- elsif ( $dl{'curl'} && check_program('curl') ){
4547- $dl{'dl'} = 'curl';
4548- $dl{'file'} = ' -L -s -o ';
4549- $dl{'no-ssl'} = ' --insecure';
4550- $dl{'stdout'} = ' -L -s ';
4551- $dl{'timeout'} = ' -y ';
4552- }
4553- elsif ($dl{'wget'} && check_program('wget') ){
4554- $dl{'dl'} = 'wget';
4555- $dl{'file'} = ' -q -O ';
4556- $dl{'no-ssl'} = ' --no-check-certificate';
4557- $dl{'spider'} = ' -q --spider';
4558- $dl{'stdout'} = ' -q -O -';
4559- $dl{'timeout'} = ' -T ';
4560- }
4561- elsif ($dl{'fetch'} && check_program('fetch')){
4562- $dl{'dl'} = 'fetch';
4563- $dl{'file'} = ' -q -o ';
4564- $dl{'no-ssl'} = ' --no-verify-peer';
4565- $dl{'stdout'} = ' -q -o -';
4566- $dl{'timeout'} = ' -T ';
4567- }
4568- elsif ( $bsd_type eq 'openbsd' && check_program('ftp') ){
4569- $dl{'dl'} = 'ftp';
4570- $dl{'file'} = ' -o ';
4571- $dl{'null'} = ' 2>/dev/null';
4572- $dl{'stdout'} = ' -o - ';
4573- $dl{'timeout'} = '';
4574- }
4575- else {
4576- $dl{'dl'} = '';
4577- }
4578- # no-ssl-opt is set to 1 with --no-ssl, so it is true, then assign
4579- $dl{'no-ssl-opt'} = $dl{'no-ssl'} if $dl{'no-ssl-opt'};
4580- eval $end if $b_log;
4581+ eval $start if $b_log;
4582+ my $quiet = '';
4583+ $dl{'no-ssl'} = '';
4584+ $dl{'null'} = '';
4585+ $dl{'spider'} = '';
4586+ # we only want to use HTTP::Tiny if it's present in user system.
4587+ # It is NOT part of core modules. IO::Socket::SSL is also required
4588+ # For some https connections so only use tiny as option if both present
4589+ if ($dl{'tiny'}){
4590+ if (check_perl_module('HTTP::Tiny') && check_perl_module('IO::Socket::SSL')){
4591+ HTTP::Tiny->import;
4592+ IO::Socket::SSL->import;
4593+ $dl{'tiny'} = 1;
4594+ }
4595+ else {
4596+ $dl{'tiny'} = 0;
4597+ }
4598+ }
4599+ # print $dl{'tiny'} . "\n";
4600+ if ($dl{'tiny'}){
4601+ $dl{'dl'} = 'tiny';
4602+ $dl{'file'} = '';
4603+ $dl{'stdout'} = '';
4604+ $dl{'timeout'} = '';
4605+ }
4606+ elsif ($dl{'curl'} && check_program('curl')){
4607+ $quiet = '-s ' if !$dbg[1];
4608+ $dl{'dl'} = 'curl';
4609+ $dl{'file'} = " -L ${quiet}-o ";
4610+ $dl{'no-ssl'} = ' --insecure';
4611+ $dl{'stdout'} = " -L ${quiet}";
4612+ $dl{'timeout'} = ' -y ';
4613+ $dl{'ua'} = ' -A ' . $dl_ua;
4614+ }
4615+ elsif ($dl{'wget'} && check_program('wget')){
4616+ $quiet = '-q ' if !$dbg[1];
4617+ $dl{'dl'} = 'wget';
4618+ $dl{'file'} = " ${quiet}-O ";
4619+ $dl{'no-ssl'} = ' --no-check-certificate';
4620+ $dl{'spider'} = " ${quiet}--spider";
4621+ $dl{'stdout'} = " $quiet -O -";
4622+ $dl{'timeout'} = ' -T ';
4623+ $dl{'ua'} = ' -U ' . $dl_ua;
4624+ }
4625+ elsif ($dl{'fetch'} && check_program('fetch')){
4626+ $quiet = '-q ' if !$dbg[1];
4627+ $dl{'dl'} = 'fetch';
4628+ $dl{'file'} = " ${quiet}-o ";
4629+ $dl{'no-ssl'} = ' --no-verify-peer';
4630+ $dl{'stdout'} = " ${quiet}-o -";
4631+ $dl{'timeout'} = ' -T ';
4632+ }
4633+ # at least openbsd/netbsd
4634+ elsif ($bsd_type && check_program('ftp')){
4635+ $dl{'dl'} = 'ftp';
4636+ $dl{'file'} = ' -o ';
4637+ $dl{'null'} = ' 2>/dev/null';
4638+ $dl{'stdout'} = ' -o - ';
4639+ $dl{'timeout'} = '';
4640+ }
4641+ else {
4642+ $dl{'dl'} = '';
4643+ }
4644+ # no-ssl-opt is set to 1 with --no-ssl, so it is true, then assign
4645+ $dl{'no-ssl-opt'} = $dl{'no-ssl'} if $dl{'no-ssl-opt'};
4646+ eval $end if $b_log;
4647 }
4648
4649 sub set_perl_downloader {
4650- my ($downloader) = @_;
4651- $downloader =~ s/perl/tiny/;
4652- return $downloader;
4653+ my ($downloader) = @_;
4654+ $downloader =~ s/perl/tiny/;
4655+ return $downloader;
4656 }
4657
4658 #### -------------------------------------------------------------------
4659@@ -2318,97 +2639,97 @@ sub set_perl_downloader {
4660 #### -------------------------------------------------------------------
4661
4662 sub error_handler {
4663- eval $start if $b_log;
4664- my ( $err, $one, $two) = @_;
4665- my ($b_help,$b_recommends);
4666- my ($b_exit,$errno) = (1,0);
4667- my $message = do {
4668- if ( $err eq 'empty' ) { 'empty value' }
4669- ## Basic rules
4670- elsif ( $err eq 'not-in-irc' ) {
4671- $errno=1; "You can't run option $one in an IRC client!" }
4672- ## Internal/external options
4673- elsif ( $err eq 'bad-arg' ) {
4674- $errno=10; $b_help=1; "Unsupported value: $two for option: $one" }
4675- elsif ( $err eq 'bad-arg-int' ) {
4676- $errno=11; "Bad internal argument: $one" }
4677- elsif ( $err eq 'distro-block' ) {
4678- $errno=20; "Option: $one has been disabled by the $self_name distribution maintainer." }
4679- elsif ( $err eq 'option-feature-incomplete' ) {
4680- $errno=21; "Option: '$one' feature: '$two' has not been implemented yet." }
4681- elsif ( $err eq 'unknown-option' ) {
4682- $errno=22; $b_help=1; "Unsupported option: $one" }
4683- ## Data
4684- elsif ( $err eq 'open-data' ) {
4685- $errno=32; "Error opening data for reading: $one \nError: $two" }
4686- elsif ( $err eq 'download-error' ) {
4687- $errno=33; "Error downloading file with $dl{'dl'}: $one \nError: $two" }
4688- ## Files:
4689- elsif ( $err eq 'copy-failed' ) {
4690- $errno=40; "Error copying file: $one \nError: $two" }
4691- elsif ( $err eq 'create' ) {
4692- $errno=41; "Error creating file: $one \nError: $two" }
4693- elsif ( $err eq 'downloader-error' ) {
4694- $errno=42; "Error downloading file: $one \nfor download source: $two" }
4695- elsif ( $err eq 'file-corrupt' ) {
4696- $errno=43; "Downloaded file is corrupted: $one" }
4697- elsif ( $err eq 'mkdir' ) {
4698- $errno=44; "Error creating directory: $one \nError: $two" }
4699- elsif ( $err eq 'open' ) {
4700- $errno=45; $b_exit=0; "Error opening file: $one \nError: $two" }
4701- elsif ( $err eq 'open-dir' ) {
4702- $errno=46; "Error opening directory: $one \nError: $two" }
4703- elsif ( $err eq 'output-file-bad' ) {
4704- $errno=47; "Value for --output-file must be full path, a writable directory, \nand include file name. Path: $two" }
4705- elsif ( $err eq 'not-writable' ) {
4706- $errno=48; "The file: $one is not writable!" }
4707- elsif ( $err eq 'open-dir-failed' ) {
4708- $errno=49; "The directory: $one failed to open with error: $two" }
4709- elsif ( $err eq 'remove' ) {
4710- $errno=50; "Failed to remove file: $one Error: $two" }
4711- elsif ( $err eq 'rename' ) {
4712- $errno=51; "There was an error moving files: $one\nError: $two" }
4713- elsif ( $err eq 'write' ) {
4714- $errno=52; "Failed writing file: $one - Error: $two!" }
4715- ## Downloaders
4716- elsif ( $err eq 'missing-downloader' ) {
4717- $errno=60; "Downloader program $two could not be located on your system." }
4718- elsif ( $err eq 'missing-perl-downloader' ) {
4719- $errno=61; $b_recommends=1; "Perl downloader missing required module." }
4720- ## FTP
4721- elsif ( $err eq 'ftp-bad-path' ) {
4722- $errno=70; "Unable to locate for FTP upload file:\n$one" }
4723- elsif ( $err eq 'ftp-connect' ) {
4724- $errno=71; "There was an error with connection to ftp server: $one" }
4725- elsif ( $err eq 'ftp-login' ) {
4726- $errno=72; "There was an error with login to ftp server: $one" }
4727- elsif ( $err eq 'ftp-upload' ) {
4728- $errno=73; "There was an error with upload to ftp server: $one" }
4729- ## Modules
4730- elsif ( $err eq 'required-module' ) {
4731- $errno=80; $b_recommends=1; "The required $one Perl module is not installed:\n$two" }
4732- ## DEFAULT
4733- else {
4734- $errno=255; "Error handler ERROR!! Unsupported options: $err!"}
4735- };
4736- print_line("Error $errno: $message\n");
4737- if ($b_help){
4738- print_line("Check -h for correct parameters.\n");
4739- }
4740- if ($b_recommends){
4741- print_line("See --recommends for more information.\n");
4742- }
4743- eval $end if $b_log;
4744- exit $errno if $b_exit && !$debugger{'no-exit'};
4745+ eval $start if $b_log;
4746+ my ($err,$one,$two) = @_;
4747+ my ($b_help,$b_recommends);
4748+ my ($b_exit,$errno) = (1,0);
4749+ my $message = do {
4750+ if ($err eq 'empty'){ 'empty value' }
4751+ ## Basic rules
4752+ elsif ($err eq 'not-in-irc'){
4753+ $errno=1; "You can't run option $one in an IRC client!" }
4754+ ## Internal/external options
4755+ elsif ($err eq 'bad-arg'){
4756+ $errno=10; $b_help=1; "Unsupported value: $two for option: $one" }
4757+ elsif ($err eq 'bad-arg-int'){
4758+ $errno=11; "Bad internal argument: $one" }
4759+ elsif ($err eq 'distro-block'){
4760+ $errno=20; "Option: $one has been disabled by the $self_name distribution maintainer." }
4761+ elsif ($err eq 'option-feature-incomplete'){
4762+ $errno=21; "Option: '$one' feature: '$two' has not been implemented yet." }
4763+ elsif ($err eq 'unknown-option'){
4764+ $errno=22; $b_help=1; "Unsupported option: $one" }
4765+ ## Data
4766+ elsif ($err eq 'open-data'){
4767+ $errno=32; "Error opening data for reading: $one \nError: $two" }
4768+ elsif ($err eq 'download-error'){
4769+ $errno=33; "Error downloading file with $dl{'dl'}: $one \nError: $two" }
4770+ ## Files:
4771+ elsif ($err eq 'copy-failed'){
4772+ $errno=40; "Error copying file: $one \nError: $two" }
4773+ elsif ($err eq 'create'){
4774+ $errno=41; "Error creating file: $one \nError: $two" }
4775+ elsif ($err eq 'downloader-error'){
4776+ $errno=42; "Error downloading file: $one \nfor download source: $two" }
4777+ elsif ($err eq 'file-corrupt'){
4778+ $errno=43; "Downloaded file is corrupted: $one" }
4779+ elsif ($err eq 'mkdir'){
4780+ $errno=44; "Error creating directory: $one \nError: $two" }
4781+ elsif ($err eq 'open'){
4782+ $errno=45; $b_exit=0; "Error opening file: $one \nError: $two" }
4783+ elsif ($err eq 'open-dir'){
4784+ $errno=46; "Error opening directory: $one \nError: $two" }
4785+ elsif ($err eq 'output-file-bad'){
4786+ $errno=47; "Value for --output-file must be full path, a writable directory, \nand include file name. Path: $two" }
4787+ elsif ($err eq 'not-writable'){
4788+ $errno=48; "The file: $one is not writable!" }
4789+ elsif ($err eq 'open-dir-failed'){
4790+ $errno=49; "The directory: $one failed to open with error: $two" }
4791+ elsif ($err eq 'remove'){
4792+ $errno=50; "Failed to remove file: $one Error: $two" }
4793+ elsif ($err eq 'rename'){
4794+ $errno=51; "There was an error moving files: $one\nError: $two" }
4795+ elsif ($err eq 'write'){
4796+ $errno=52; "Failed writing file: $one - Error: $two!" }
4797+ ## Downloaders
4798+ elsif ($err eq 'missing-downloader'){
4799+ $errno=60; "Downloader program $two could not be located on your system." }
4800+ elsif ($err eq 'missing-perl-downloader'){
4801+ $errno=61; $b_recommends=1; "Perl downloader missing required module." }
4802+ ## FTP
4803+ elsif ($err eq 'ftp-bad-path'){
4804+ $errno=70; "Unable to locate for FTP upload file:\n$one" }
4805+ elsif ($err eq 'ftp-connect'){
4806+ $errno=71; "There was an error with connection to ftp server: $one" }
4807+ elsif ($err eq 'ftp-login'){
4808+ $errno=72; "There was an error with login to ftp server: $one" }
4809+ elsif ($err eq 'ftp-upload'){
4810+ $errno=73; "There was an error with upload to ftp server: $one" }
4811+ ## Modules
4812+ elsif ($err eq 'required-module'){
4813+ $errno=80; $b_recommends=1; "The required $one Perl module is not installed:\n$two" }
4814+ ## DEFAULT
4815+ else {
4816+ $errno=255; "Error handler ERROR!! Unsupported options: $err!"}
4817+ };
4818+ print_line("Error $errno: $message\n");
4819+ if ($b_help){
4820+ print_line("Check -h for correct parameters.\n");
4821+ }
4822+ if ($b_recommends){
4823+ print_line("See --recommends for more information.\n");
4824+ }
4825+ eval $end if $b_log;
4826+ exit $errno if $b_exit && !$debugger{'no-exit'};
4827 }
4828
4829 sub error_defaults {
4830- my ($type,$one) = @_;
4831- $one ||= '';
4832- my %errors = (
4833- 'download-error' => "Download Failure:\n$one\n",
4834- );
4835- return $errors{$type};
4836+ my ($type,$one) = @_;
4837+ $one ||= '';
4838+ my %errors = (
4839+ 'download-error' => "Download Failure:\n$one\n",
4840+ );
4841+ return $errors{$type};
4842 }
4843
4844 #### -------------------------------------------------------------------
4845@@ -2418,615 +2739,756 @@ sub error_defaults {
4846 ## CheckRecommends
4847 {
4848 package CheckRecommends;
4849+my (@modules);
4850 sub run {
4851- main::error_handler('not-in-irc', 'recommends') if $b_irc;
4852- my (@data,@rows);
4853- my $line = make_line();
4854- my $pm = get_pm();
4855- @data = basic_data($line);
4856- push @rows,@data;
4857- if (!$bsd_type){
4858- @data = check_items('required system directories',$line,$pm);
4859- push @rows,@data;
4860- }
4861- @data = check_items('recommended system programs',$line,$pm);
4862- push @rows,@data;
4863- @data = check_items('recommended display information programs',$line,$pm);
4864- push @rows,@data;
4865- @data = check_items('recommended downloader programs',$line,$pm);
4866- push @rows,@data;
4867- @data = check_items('recommended Perl modules',$line,$pm);
4868- push @rows,@data;
4869- @data = check_items('recommended directories',$line,'');
4870- push @rows,@data;
4871- @data = check_items('recommended files',$line,'');
4872- push @rows,@data;
4873- @data = (
4874- ['0', '', '', "$line"],
4875- ['0', '', '', "Ok, all done with the checks. Have a nice day."],
4876- ['0', '', '', " "],
4877- );
4878- push @rows,@data;
4879- #print Data::Dumper::Dumper \@rows;
4880- main::print_basic(@rows);
4881- exit 0; # shell true
4882+ main::error_handler('not-in-irc', 'recommends') if $b_irc;
4883+ my (@data,@rows);
4884+ my $line = make_line();
4885+ my $pm = get_pm();
4886+ @data = basic_data($line,$pm);
4887+ push(@rows, @data);
4888+ if (!$bsd_type){
4889+ @data = check_items('required system directories',$line,$pm);
4890+ push(@rows, @data);
4891+ }
4892+ @data = check_items('recommended system programs',$line,$pm);
4893+ push(@rows, @data);
4894+ @data = check_items('recommended display information programs',$line,$pm);
4895+ push(@rows, @data);
4896+ @data = check_items('recommended downloader programs',$line,$pm);
4897+ push(@rows, @data);
4898+ if (!$bsd_type){
4899+ @data = check_items('recommended kernel modules',$line,$pm);
4900+ push(@rows, @data);
4901+ }
4902+ @data = check_items('recommended Perl modules',$line,$pm);
4903+ push(@rows, @data);
4904+ @data = check_items('recommended directories',$line,'');
4905+ push(@rows, @data);
4906+ @data = check_items('recommended files',$line,'');
4907+ push(@rows, @data);
4908+ @data = (
4909+ ['0', '', '', "$line"],
4910+ ['0', '', '', "Ok, all done with the checks. Have a nice day."],
4911+ ['0', '', '', " "],
4912+ );
4913+ push(@rows, @data);
4914+ # print Data::Dumper::Dumper \@rows;
4915+ main::print_basic(\@rows);
4916+ exit 0; # shell true
4917 }
4918
4919 sub basic_data {
4920- my ($line) = @_;
4921- my (@data,@rows);
4922- my $client = $client{'name-print'};
4923- $client .= ' ' . $client{'version'} if $client{'version'};
4924- my $default_shell = 'N/A';
4925- if ($ENV{'SHELL'}){
4926- $default_shell = $ENV{'SHELL'};
4927- $default_shell =~ s/.*\///;
4928- }
4929- my $sh = main::check_program('sh');
4930- my $sh_real = Cwd::abs_path($sh);
4931- @rows = (
4932- ['0', '', '', "$self_name will now begin checking for the programs it needs
4933- to operate."],
4934- ['0', '', '', "" ],
4935- ['0', '', '', "Check $self_name --help or the man page (man $self_name)
4936- to see what options are available." ],
4937- ['0', '', '', "$line" ],
4938- ['0', '', '', "Test: core tools:" ],
4939- ['0', '', '', "" ],
4940- ['0', '', '', "Perl version: ^$]" ],
4941- ['0', '', '', "Current shell: " . $client ],
4942- ['0', '', '', "Default shell: " . $default_shell ],
4943- ['0', '', '', "sh links to: $sh_real" ],
4944- );
4945- return @rows;
4946+ my ($line,$pm_local) = @_;
4947+ my (@data,@rows);
4948+ my $client = $client{'name-print'};
4949+ $pm_local ||= 'N/A';
4950+ $client .= ' ' . $client{'version'} if $client{'version'};
4951+ my $default_shell = 'N/A';
4952+ if ($ENV{'SHELL'}){
4953+ $default_shell = $ENV{'SHELL'};
4954+ $default_shell =~ s/.*\///;
4955+ }
4956+ my $sh = main::check_program('sh');
4957+ my $sh_real = Cwd::abs_path($sh);
4958+ @rows = (
4959+ ['0', '', '', "$self_name will now begin checking for the programs it needs
4960+ to operate."],
4961+ ['0', '', '', "" ],
4962+ ['0', '', '', "Check $self_name --help or the man page (man $self_name)
4963+ to see what options are available." ],
4964+ ['0', '', '', "$line" ],
4965+ ['0', '', '', "Test: core tools:" ],
4966+ ['0', '', '', "" ],
4967+ ['0', '', '', "Perl version: ^$]" ],
4968+ ['0', '', '', "Current shell: " . $client ],
4969+ ['0', '', '', "Default shell: " . $default_shell ],
4970+ ['0', '', '', "sh links to: $sh_real" ],
4971+ ['0', '', '', "Package manager: $pm_local" ],
4972+ );
4973+ return @rows;
4974 }
4975 sub check_items {
4976- my ($type,$line,$pm) = @_;
4977- my (@data,%info,@missing,$row,@rows,$result,@unreadable);
4978- my ($b_dir,$b_file,$b_module,$b_program,$item);
4979- my ($about,$extra,$extra2,$extra3,$extra4,$info_os,$install) = ('','','','','','info','');
4980- if ($type eq 'required system directories'){
4981- @data = qw(/proc /sys);
4982- $b_dir = 1;
4983- $item = 'Directory';
4984- }
4985- elsif ($type eq 'recommended system programs'){
4986- if ($bsd_type){
4987- @data = qw(camcontrol dig dmidecode fdisk file glabel gpart ifconfig ipmi-sensors
4988- ipmitool lsusb sudo smartctl sysctl tree upower uptime usbdevs);
4989- $info_os = 'info-bsd';
4990- }
4991- else {
4992- @data = qw(blockdev dig dmidecode fdisk file hddtemp ifconfig ip ipmitool
4993- ipmi-sensors lsblk lsusb modinfo runlevel sensors strings sudo tree upower uptime);
4994- }
4995- $b_program = 1;
4996- $item = 'Program';
4997- $extra2 = "Note: IPMI sensors are generally only found on servers. To access
4998- that data, you only need one of the ipmi items.";
4999- }
5000- elsif ($type eq 'recommended display information programs'){
The diff has been truncated for viewing.

Subscribers

People subscribed via source and target branches