Merge ~sylvain-pineau/plainbox-provider-checkbox:inxi_2021_07_21 into plainbox-provider-checkbox:master
- Git
- lp:~sylvain-pineau/plainbox-provider-checkbox
- inxi_2021_07_21
- Merge into 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) |
Related bugs: |
Reviewer | Review Type | Date Requested | Status |
---|---|---|---|
Maciej Kisielewski (community) | Approve | ||
Review via email:
|
Commit message
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.
Preview Diff
[H/L] Next/Prev Comment, [J/K] Next/Prev File, [N/P] Next/Prev Hunk
1 | diff --git a/bin/inxi_snapshot b/bin/inxi_snapshot |
2 | index 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.
+1