File Coverage

blib/lib/MDK/Common/System.pm
Criterion Covered Total %
statement 13 206 6.3
branch 0 92 0.0
condition 0 34 0.0
subroutine 5 38 13.1
pod 28 34 82.3
total 46 404 11.3


line stmt bran cond sub pod time code
1             package MDK::Common::System;
2              
3             =head1 NAME
4              
5             MDK::Common::System - system-related useful functions
6              
7             =head1 SYNOPSIS
8              
9             use MDK::Common::System qw(:all);
10              
11             =head1 EXPORTS
12              
13             =over
14              
15             =item %compat_arch
16              
17             architecture compatibility mapping (eg: k6 => i586, k7 => k6 ...)
18              
19             =item %printable_chars
20              
21             7 bit ascii characters
22              
23             =item $sizeof_int
24              
25             sizeof(int)
26              
27             =item $bitof_int
28              
29             $sizeof_int * 8
30              
31             =item arch()
32              
33             return the architecture (eg: i686, ppc, ia64, k7...)
34              
35             =item typeFromMagic(FILENAME, LIST)
36              
37             find the first corresponding magic in FILENAME. eg of LIST:
38              
39             [ 'empty', 0, "\0\0\0\0" ],
40             [ 'grub', 0, "\xEBG", 0x17d, "stage1 \0" ],
41             [ 'lilo', 0x2, "LILO" ],
42             sub { my ($F) = @_;
43             #- standard grub has no good magic (Mageia's grub is patched to have "GRUB" at offset 6)
44             #- so scanning a range of possible places where grub can have its string
45             my ($min, $max, $magic) = (0x176, 0x181, "GRUB \0");
46             my $tmp;
47             sysseek($F, 0, 0) && sysread($F, $tmp, $max + length($magic)) or return;
48             substr($tmp, 0, 2) eq "\xEBH" or return;
49             index($tmp, $magic, $min) >= 0 && "grub";
50             },
51              
52             where each entry is [ magic_name, offset, string, offset, string, ... ].
53              
54             =item list_passwd()
55              
56             return the list of users as given by C (see perlfunc)
57              
58             =item is_real_user()
59              
60             checks whether or not the user is a system user or a real user
61              
62             =item is_real_group()
63              
64             checks whether or not the group is a system group or a real group
65              
66             =item list_home()
67              
68             return the list of home (eg: /home/foo, /home/pixel, ...)
69              
70             =item list_skels()
71              
72             return the directories where we can find dot files: homes, /root and /etc/skel
73              
74             =item list_users()
75              
76             return the list of unprivilegied users (uses the is_real_user function to filter
77             out system users from the full list)
78              
79             =item syscall_(NAME, PARA)
80              
81             calls the syscall NAME
82              
83             =item psizeof(STRING)
84              
85             useful to know the length of a C format string.
86              
87             psizeof("I I I C C S") = 4 + 4 + 4 + 1 + 1 + 2 = 16
88              
89             =item availableMemory()
90              
91             size of swap + memory
92              
93             =item availableRamMB()
94              
95             size of RAM as reported by the BIOS (it is a round number that can be
96             displayed or given as "mem=128M" to the kernel)
97              
98             =item gettimeofday()
99              
100             returns the epoch in microseconds
101              
102             =item unix2dos(STRING)
103              
104             takes care of CR/LF translation
105              
106             =item whereis_binary(STRING)
107              
108             return the first absolute file in $PATH (similar to which(1) and whereis(1))
109              
110             =item getVarsFromSh(FILENAME)
111              
112             returns a hash associating shell variables to their value. useful for config
113             files such as /etc/sysconfig files
114              
115             =item setVarsInSh(FILENAME, HASH REF)
116              
117             write file in shell format association a shell variable + value for each
118             key/value
119              
120             =item setVarsInSh(FILENAME, HASH REF, LIST)
121              
122             restrict the fields that will be printed to LIST
123              
124             =item setVarsInShMode(FILENAME, INT, HASH REF, LIST)
125              
126             like setVarsInSh with INT being the chmod value for the config file
127              
128             =item addVarsInSh(FILENAME, HASH REF)
129              
130             like setVarsInSh but keeping the entries in the file
131              
132             =item addVarsInSh(FILENAME, HASH REF, LIST)
133              
134             like setVarsInSh but keeping the entries in the file
135              
136             =item addVarsInShMode(FILENAME, INT, HASH REF, LIST)
137              
138             like addVarsInShMode but keeping the entries in the file
139              
140             =item setExportedVarsInCsh(FILENAME, HASH REF, LIST)
141              
142             same as C for csh format
143              
144             =item template2file(FILENAME_IN, FILENAME_OUT, HASH)
145              
146             read in a template file, replace keys @@@key@@@ with value, save it in out
147             file
148              
149             =item template2userfile(PREFIX, FILENAME_IN, FILENAME_OUT, BOOL, HASH)
150              
151             read in a template file, replace keys @@@key@@@ with value, save it in every homes.
152             If BOOL is true, overwrite existing files. FILENAME_OUT must be a relative filename
153              
154             =item read_gnomekderc(FILENAME, STRING)
155              
156             reads GNOME-like and KDE-like config files (aka windows-like).
157             You must give a category. eg:
158              
159             read_gnomekderc("/etc/skels/.kderc", 'KDE')
160              
161             =item update_gnomekderc(FILENAME, STRING, HASH)
162              
163             modifies GNOME-like and KDE-like config files (aka windows-like).
164             If the category doesn't exist, it creates it. eg:
165              
166             update_gnomekderc("/etc/skels/.kderc", 'KDE',
167             kfmIconStyle => "Large")
168              
169             =item fuzzy_pidofs(REGEXP)
170              
171             return the list of process ids matching the regexp
172              
173             =back
174              
175             =head1 OTHER
176              
177             =over
178              
179             =item better_arch(ARCH1, ARCH2)
180              
181             is ARCH1 compatible with ARCH2?
182              
183             better_arch('i386', 'ia64') and better_arch('ia64', 'i386') are false
184              
185             better_arch('k7', 'k6') is true and better_arch('k6', 'k7') is false
186              
187             =item compat_arch(STRING)
188              
189             test the architecture compatibility. eg:
190              
191             compat_arch('i386') is false on a ia64
192              
193             compat_arch('k6') is true on a k6 and k7 but false on a i386 and i686
194              
195             =back
196              
197             =head1 SEE ALSO
198              
199             L
200              
201             =cut
202              
203              
204 1     1   6 use MDK::Common::Math;
  1         1  
  1         36  
205 1     1   5 use MDK::Common::File;
  1         1  
  1         25  
206 1     1   4 use MDK::Common::DataStructure;
  1         1  
  1         23  
207              
208 1     1   4 use Exporter;
  1         2  
  1         2754  
209             our @ISA = qw(Exporter);
210             our @EXPORT_OK = qw(%compat_arch $printable_chars $sizeof_int $bitof_int arch distrib typeFromMagic list_passwd is_real_user is_real_group list_home list_skels list_users syscall_ psizeof availableMemory availableRamMB gettimeofday unix2dos whereis_binary getVarsFromSh setVarsInSh setVarsInShMode addVarsInSh addVarsInShMode setExportedVarsInSh setExportedVarsInCsh template2file template2userfile read_gnomekderc update_gnomekderc fuzzy_pidofs); #);
211             our %EXPORT_TAGS = (all => [ @EXPORT_OK ]);
212              
213              
214             our %compat_arch = ( #- compatibilty arch mapping.
215             'noarch' => undef,
216             'ia32' => 'noarch',
217             'i386' => 'ia32',
218             'i486' => 'i386',
219             'i586' => 'i486',
220             'i686' => 'i586',
221             'i786' => 'i686',
222             'k6' => 'i586',
223             'k7' => 'k6',
224             'k8' => 'k7',
225             'x86_64' => 'i686',
226             'amd64' => 'x86_64',
227             'ia64' => 'noarch',
228             'ppc' => 'noarch',
229             'alpha' => 'noarch',
230             'sparc' => 'noarch',
231             'sparc32' => 'sparc',
232             'sparc64' => 'sparc32',
233             'ia64' => 'noarch',
234             );
235              
236             our $printable_chars = "\x20-\x7E";
237             our $sizeof_int = psizeof("i");
238             our $bitof_int = $sizeof_int * 8;
239              
240              
241             sub arch() {
242 0     0 1 0 my $SYS_NMLN = 65;
243 0         0 my $format = "Z$SYS_NMLN" x 6;
244 0         0 my $t = pack $format;
245 0         0 syscall_('uname', $t);
246 0         0 (unpack($format, $t))[4];
247             }
248             sub better_arch {
249 0     0 1 0 my ($new, $old) = @_;
250 0   0     0 while ($new && $new ne $old) { $new = $compat_arch{$new} }
  0         0  
251 0         0 $new;
252             }
253 0     0 1 0 sub compat_arch { better_arch(arch(), $_[0]) }
254              
255             sub distrib() {
256 0     0 0 0 my $release = MDK::Common::File::cat_('/etc/release');
257 0         0 my ($real_system, $real_product) = $release =~ /(.*) release ([\d.]+)/;
258 0         0 my $oem_config = '/etc/sysconfig/oem';
259 0   0     0 my %oem = -f $oem_config && getVarsFromSh($oem_config);
260             #- (blino) FIXME: merge with release functions from /usr/lib/libDrakX/common.pm (including product.id parsing)
261 0         0 my ($default_company) = split(' ', $real_system);
262 0   0     0 my $company = $oem{COMPANY} || $default_company || 'Unknown vendor';
263 0   0     0 my $system = $oem{SYSTEM} || $real_system;
264 0   0     0 my $product = $oem{PRODUCT} || $real_product;
265 0         0 (company => $company, system => $system, product => $product, real_system => $real_system, real_product => $real_product);
266             }
267              
268             sub typeFromMagic {
269 0     0 1 0 my $f = shift;
270 0 0       0 sysopen(my $F, $f, 0) or return;
271              
272 0         0 my $tmp;
273 0         0 M: foreach (@_) {
274 0 0       0 if (ref($_) eq 'CODE') {
275 0 0       0 my $name = $_->($F) or next M;
276 0         0 return $name;
277             } else {
278 0         0 my ($name, @l) = @$_;
279 0         0 while (@l) {
280 0         0 my ($offset, $signature) = splice(@l, 0, 2);
281 0 0       0 sysseek($F, $offset, 0) or next M;
282 0         0 sysread($F, $tmp, length $signature);
283 0 0       0 $tmp eq $signature or next M;
284             }
285 0         0 return $name;
286             }
287             }
288 0         0 undef;
289             }
290              
291              
292             sub list_passwd() {
293 0     0 1 0 my (@l, @e);
294 0         0 setpwent();
295 0         0 while (@e = getpwent()) { push @l, [ @e ] }
  0         0  
296 0         0 endpwent();
297 0         0 @l;
298             }
299             sub is_real_user {
300 0     0 1 0 my ($username) = @_;
301              
302 0 0       0 return 0 if $username eq "nobody";
303              
304             # We consider real users to be those users who:
305             # Have a UID >= 1000
306             # or
307             # Have a UID >= 500
308             # and have a homedir that is not / or does not start with /var or /run
309             # and have a shell that does not end in "nologin" or "false"
310              
311 0         0 my (undef, undef, $uid, undef, undef, undef, undef, $homedir, $shell) = getpwnam($username);
312 0 0 0     0 ($uid >= 1000 || ($uid >= 500 && $homedir !~ m!^/($|var/|run/)! && $shell !~ /(nologin|false)$/));
      0        
313             }
314             sub is_real_group {
315 0     0 1 0 my ($groupname) = @_;
316              
317 0 0       0 return 0 if $groupname eq "nogroup";
318              
319 0         0 my (undef, undef, $gid, $members) = getgrnam($groupname);
320 0 0       0 return 0 if $gid < 500;
321 0 0       0 return 1 if $gid >= 1000;
322              
323             # We are in the range 500-1000, so we need some heuristic.
324             # We consider ourselves a "real" group if this is the primary group of a user
325             # with the same name, or we have any member users who are "real"
326              
327 0         0 my (undef, undef, undef, $ugid) = getpwnam($groupname);
328 0 0 0     0 return 1 if $ugid == $gid && is_real_user($groupname);
329              
330             # OK we're not a primary group, but perhaps we have some real members?
331 0         0 foreach (split(' ', $members)) {
332 0 0       0 return 1 if is_real_user($_);
333             }
334 0         0 return 0;
335             }
336             sub list_home() {
337 0     0 1 0 MDK::Common::DataStructure::uniq(map { $_->[7] } grep { is_real_user($_->[0]) } list_passwd());
  0         0  
  0         0  
338             }
339             sub list_skels {
340 0     0 1 0 my ($prefix, $suffix) = @_;
341 0 0       0 grep { -d $_ && -w $_ } map { "$prefix$_/$suffix" } '/etc/skel', '/root', list_home();
  0         0  
  0         0  
342             }
343              
344             sub list_users() {
345 0 0   0 1 0 MDK::Common::DataStructure::uniq(map { is_real_user($_->[0]) ? $_->[0] : () } list_passwd());
  0         0  
346             }
347              
348              
349              
350             sub syscall_ {
351 0     0 1 0 my $f = shift;
352              
353             #- load syscall.ph in package "main". If every use of syscall.ph do the same, all will be nice
354             package main;
355 0         0 require 'syscall.ph';
356              
357 0         0 syscall(&{"main::SYS_$f"}, @_) == 0;
  0         0  
358             }
359              
360              
361             #- return the size of the partition and its free space in KiB
362             sub df {
363 0     0 0 0 my ($mntpoint) = @_;
364 0         0 require Filesys::Df;
365 0         0 my $df = Filesys::Df::df($mntpoint, 1024); # ask 1kb values
366 0         0 @$df{qw(blocks bfree)};
367             }
368              
369 0     0 0 0 sub sync() { syscall_('sync') }
370 1     1 1 3 sub psizeof { length pack $_[0] }
371 0     0 1   sub availableMemory() { MDK::Common::Math::sum(map { /(\d+)/ } grep { /^(MemTotal|SwapTotal):/ } MDK::Common::File::cat_("/proc/meminfo")) }
  0            
  0            
372 0     0 1   sub availableRamMB() { 4 * MDK::Common::Math::round((-s '/proc/kcore') / 1024 / 1024 / 4) }
373 0 0   0 1   sub gettimeofday() { my $t = pack "LL"; syscall_('gettimeofday', $t, 0) or die "gettimeofday failed: $!\n"; unpack("LL", $t) }
  0            
  0            
374 0     0 1   sub unix2dos { local $_ = $_[0]; s/\015$//mg; s/$/\015/mg; $_ }
  0            
  0            
  0            
375              
376             sub expandLinkInChroot {
377 0     0 0   my ($file, $prefix) = @_;
378 0           my $l = readlink "$prefix$file";
379 0 0         return unless $l;
380 0 0         return $l if $l =~ m!^/!;
381 0           my $path = $file;
382 0           $path =~ s!/[^/]*$!!;
383 0           $path .= "/$l";
384 0           return $path;
385             }
386              
387             sub whereis_binary {
388 0     0 1   my ($prog, $o_prefix) = @_;
389 0 0         if ($prog =~ m!/!) {
390 0           require MDK::Common::Various;
391 0           warn qq(don't call whereis_binary with a name containing a "/" (the culprit is: $prog)\n) . MDK::Common::Various::backtrace();
392 0           return;
393             }
394 0           foreach (split(':', $ENV{PATH})) {
395 0           my $f = "$_/$prog";
396 0           my $links = 0;
397 0           my $l = $f;
398 0           while (-l "$o_prefix$l") {
399 0           $l = expandLinkInChroot($l, $o_prefix);
400 0 0         if ($links++ > 16) {
401 0           warn qq(symlink recursion too deep in whereis_binary\n);
402 0           return;
403             }
404             }
405 0 0         -x "$o_prefix$l" and return $f;
406             }
407             }
408              
409             sub getVarsFromSh {
410 0     0 1   my %l;
411 0 0         open(my $F, $_[0]) or return;
412 0           local $_;
413 0           while (<$F>) {
414 0           s/^\s*#.*//; # remove comment-only lines
415 0           s/^\s*//; # leading space
416 0 0         my ($v, $val) = /^(\w+)=(.*)/ or next;
417 0 0         if ($val =~ /^"(.*)"(\s+#.*)?$/) {
    0          
418 0           $val = $1;
419             } elsif ($val =~ /^'(.*)'(\s+#.*)?$/) {
420 0           $val = $1;
421 0           $val =~ s/(^|[^'])'\\''/$1'/g;
422             }
423 0           $l{$v} = $val;
424             }
425 0           %l;
426             }
427              
428             sub addVarsInSh {
429 0     0 1   my ($file, $l, @fields) = @_;
430 0           addVarsInShMode($file, 0777 ^ umask(), $l, @fields);
431             }
432              
433             sub addVarsInShMode {
434 0     0 1   my ($file, $mod, $l, @fields) = @_;
435 0 0         my %l = @fields ? map { $_ => $l->{$_} } @fields : %$l;
  0            
436 0           my %l2 = getVarsFromSh($file);
437              
438             # below is add2hash_(\%l, \%l2);
439 0   0       exists $l{$_} or $l{$_} = $l2{$_} foreach keys %l2;
440              
441 0           setVarsInShMode($file, $mod, \%l);
442             }
443              
444             sub setVarsInSh {
445 0     0 1   my ($file, $l, @fields) = @_;
446 0           setVarsInShMode($file, 0777 ^ umask(), $l, @fields);
447             }
448              
449             sub quoteForSh {
450 0     0 0   my ($val) = @_;
451 0 0         if ($val =~ /["`\$]/) {
    0          
452 0           $val =~ s/(')/$1\\$1$1/g;
453 0           $val = qq('$val');
454             } elsif ($val =~ /[\(\)'|\s\\;<>&#\[\]~{}*?]/) {
455 0           $val = qq("$val");
456             }
457 0           $val;
458             }
459              
460             sub setVarsInShMode {
461 0     0 1   my ($file, $mod, $l, @fields) = @_;
462 0 0         @fields = sort keys %$l unless @fields;
463             my $string = join('',
464 0           map { "$_=" . quoteForSh($l->{$_}) . "\n" } grep { $l->{$_} } @fields
  0            
  0            
465             );
466 0 0         if ($file =~ m!^/home/!) {
467 0           MDK::Common::File::secured_output($file, $string);
468             } else {
469 0           MDK::Common::File::output($file, $string);
470             }
471              
472 0           chmod $mod, $file;
473             }
474              
475             sub setExportedVarsInSh {
476 0     0 0   my ($file, $l, @fields) = @_;
477 0 0         @fields = keys %$l unless @fields;
478              
479             MDK::Common::File::output($file,
480 0 0         (map { $l->{$_} ? "$_=" . quoteForSh($l->{$_}) . "\n" : () } @fields),
  0 0          
481             @fields ? "export " . join(" ", @fields) . "\n" : (),
482             );
483             }
484              
485             sub setExportedVarsInCsh {
486 0     0 1   my ($file, $l, @fields) = @_;
487 0 0         @fields = keys %$l unless @fields;
488              
489 0 0         MDK::Common::File::output($file, map { $l->{$_} ? "setenv $_ " . quoteForSh($l->{$_}) . "\n" : () } @fields);
  0            
490             }
491              
492             sub template2file {
493 0     0 1   my ($in, $out, %toreplace) = @_;
494 0           MDK::Common::File::output($out, map { s/@@@(.*?)@@@/$toreplace{$1}/g; $_ } MDK::Common::File::cat_($in));
  0            
  0            
495             }
496             sub template2userfile {
497 0     0 1   my ($prefix, $in, $out_rel, $force, %toreplace) = @_;
498              
499 0           foreach (list_skels($prefix, $out_rel)) {
500 0 0 0       -d MDK::Common::File::dirname($_) or !-e $_ or $force or next;
      0        
501              
502 0           template2file($in, $_, %toreplace);
503 0 0         m|/home/(.+?)/| and chown(getpwnam($1), getgrnam($1), $_);
504             }
505             }
506              
507             sub read_gnomekderc {
508 0     0 1   my ($file, $category) = @_;
509 0           my %h;
510 0           foreach (MDK::Common::File::cat_($file), "[NOCATEGORY]\n") {
511 0 0         if (/^\s*\[\Q$category\E\]/i ... /^\[/) {
512 0 0         $h{$1} = $2 if /^\s*([^=]*?)=(.*)/;
513             }
514             }
515 0           %h;
516             }
517              
518             sub update_gnomekderc {
519 0     0 1   my ($file, $category, %subst_) = @_;
520              
521 0           my %subst = map { lc($_) => [ $_, $subst_{$_} ] } keys %subst_;
  0            
522              
523 0           my $s;
524 0 0         defined($category) or $category = "DEFAULTCATEGORY";
525 0           foreach ("[DEFAULTCATEGORY]\n", MDK::Common::File::cat_($file), "[NOCATEGORY]\n") {
526 0 0         if (my $i = /^\s*\[\Q$category\E\]/i ... /^\[/) {
527 0 0         if ($i =~ /E/) { #- for last line of category
    0          
528 0           chomp $s; $s .= "\n";
  0            
529 0           $s .= "$_->[0]=$_->[1]\n" foreach values %subst;
530 0           %subst = ();
531             } elsif (/^\s*([^=]*?)=/) {
532 0 0         if (my $e = delete $subst{lc($1)}) {
533 0           $_ = "$1=$e->[1]\n";
534             }
535             }
536             }
537 0 0         $s .= $_ if !/^\[(NO|DEFAULT)CATEGORY\]/;
538             }
539              
540             #- if category has not been found above (DEFAULTCATEGORY is always found).
541 0 0         if (keys %subst) {
542 0           chomp $s;
543 0           $s .= "\n[$category]\n";
544 0           $s .= "$_->[0]=$_->[1]\n" foreach values %subst;
545             }
546              
547 0           MDK::Common::File::output_p($file, $s);
548              
549             }
550              
551             sub fuzzy_pidofs {
552 0     0 1   my ($regexp) = @_;
553             grep {
554 0 0         if (/^(\d+)$/) {
  0            
555 0   0       my $s = MDK::Common::File::cat_("/proc/$_/cmdline") ||
556             readlink("/proc/$_/exe") ||
557             MDK::Common::File::cat_("/proc/$_/stat") =~ /\s(\S+)/ && $1 ||
558             '';
559 0           $s =~ /$regexp/;
560             } else {
561 0           0;
562             }
563             } MDK::Common::File::all('/proc');
564             }
565              
566             1;