1#! @PERL@ -w 2 3# stowES - stow Enhancement Script 4# Copyright (C) 2000-2006 Adam Lackorzynski <adam@os.inf.tu-dresden.de> 5# 6# $Id: stowES.in 116 2013-10-17 16:54:49Z adaml $ 7# 8# This program is free software; you can redistribute it and/or modify 9# it under the terms of the GNU General Public License as published by 10# the Free Software Foundation; either version 2 of the License, or 11# (at your option) any later version. 12# 13# This program is distributed in the hope that it will be useful, 14# but WITHOUT ANY WARRANTY; without even the implied warranty of 15# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 16# GNU General Public License for more details. 17# 18# You should have received a copy of the GNU General Public License 19# along with this program; if not, write to the Free Software 20# Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA 21 22 23## --------------------------- 24 25use strict; 26use Getopt::Long; 27use FileHandle; 28use Cwd; 29require 5.004; 30use POSIX qw(locale_h); 31 32use diagnostics; 33use Carp (); 34# switch these two off when doing a real release 35#local $SIG{__WARN__} = \&Carp::cluck; 36#local $SIG{__DIE__} = \&Carp::confess; 37 38my $ProgramName = $0; 39$ProgramName =~ s,.*/,,; 40 41my $DEV = 0; # set to "1" while developing will switch on 42 # some additional checks not necessary for normal use 43my $Version = '@VERSION@'; 44my $VersionString = 'stowES - stow enhancement script'; 45 46# environment variable for storing options 47my $ENV_STOWES = 'STOWES'; 48 49my @Command; 50my $Verbose; 51 52my $Umask = 022; 53 54my $TargetDir = '/usr/local'; 55my $StowDirName = 'stow'; 56my $StowDir = $TargetDir."/".$StowDirName; 57my $ConfigDirName = '.config'; 58my $DumpDir = '/tmp'; 59my $SubDirName = ''; 60my $InfoDir = 'info'; # or 'share/info' 61 62my $ActualCommand = undef; 63 64my $ContentSearchPattern = '\Wstow\W'; 65 66my $DependencyFileName = 'dependencies'; 67my $ChecksumFileName = 'md5sums'; 68my $CreatorInfoFileName = 'creatorinfo'; 69 70my $ContentSearchFile = '/dev/null'; 71my $LogFile = '/dev/null'; 72my $OutputFile = '-'; 73 74my $ProceedAllPackages = 0; 75my $RemoveSource = 0; 76my $Ambiguous = 0; 77my $DryRun = 0; 78my $Continue = 0; 79my $ParallelJobs = 1; 80 81my $BoolCheckIn = 1; 82my $BoolDepends = 1; 83my $BoolChecksums = 1; 84my $BoolCheckChecksums = 1; 85my $BoolStrip = 0; 86my $BoolConfigure = 1; 87my $BoolMake = 1; 88my $BoolMakeCheck = 1; 89my $BoolRotateInstall = 0; 90my $BoolForce = 0; 91my $BoolUseSavedOptions= 0; 92my $BoolNoInstallInfo = 0; 93 94my $PackageSuffix = undef; 95 96my %ParamConfigure; 97my %ParamMake; 98 99my @rcFiles = ('@sysconfdir@/stowESrc', '~/.stowESrc'); 100my @ConfigFiles = (); # config-files given by the user 101 102my %Progs = ( make => 'make', 103 md5sum => 'md5', 104 stow => 'stow', 105 gzip => 'gzip', 106 bzip2 => 'bzip2', 107 tar => 'tar', 108 rm => 'rm', 109 cat => 'cat', 110 mv => 'mv', 111 strip => 'strip', 112 ldd => 'ldd', 113 uname => 'uname', 114 ldconfig => '/sbin/ldconfig', # always full path for ldconfig 115 'install-info' => 'install-info', 116 ); 117# Normally we complain if we can't find a certain program from the list 118# above, but in some cases we can just switch off some functions 119my %ProgsFailFuncs = ( 'install-info' => sub { $BoolNoInstallInfo = 1; }, ); 120 121my @Commands = sort 122 qw/make makeinst instpack remove checkin checkout depends checksums 123 chkchksums package untar install strip list help version config 124 contsearch rename contents checklibs checktarget checkstow rebuild 125 shell showconfig exchange confhelp/; 126 127my %CommandAliases = # alias => original_command 128 ( 'ci' => 'checkin', 129 'co' => 'checkout', 130 'cnf' => 'config', 131 'cfg' => 'config', 132 'rm' => 'remove', 133 'ls' => 'list', 134 'mk' => 'make', 135 'cs' => 'checkstow', 136 'ct' => 'checktarget', 137 'hlp' => 'help', 138 'mkin' => 'makeinst', 139 'chlp' => 'confhelp', 140 ); 141 142my $PackageName = undef; 143 144my $MakeErrorScanPattern = '^make.*: \*\*\* \[.+\] Error'; 145my $ConfigureErrorScanPattern = '^\*\*\* |configure: error: '; 146 147my @ConfigVarList = 148 qw/@Commands %ParamConfigure %ParamMake $Continue 149 $ProgramName $Version @Command $Verbose 150 $TargetDir $StowDirName $StowDir $DumpDir $ConfigDirName 151 $DependencyFileName $ChecksumFileName $PackageName 152 $ContentSearchPattern @ConfigFiles $RemoveSource 153 $ContentSearchFile $ProceedAllPackages $PackageSuffix 154 @rcFiles %Progs $Ambiguous $DryRun $LogFile $OutputFile 155 $BoolCheckIn $BoolDepends $BoolChecksums $BoolCheckChecksums $BoolStrip 156 %CommandAliases $ActualCommand $BoolConfigure $BoolMake $SubDirName 157 $ParallelJobs $BoolNoInstallInfo $BoolUseSavedOptions $BoolForce 158 $BoolRotateInstall $BoolMakeCheck /; 159 160my @exclude_dep_libs = 161 ('ld-linux.so', 'nfslock.so', 'libc.so', 'libm.so'); 162 163my $CallLdconfig = 0; 164 165# --==---==---==---==---==---==---==---==---==---==---==---==-- 166# -=0=--=0=--=0=--=0=--=0=--=0=--=0=--=0=--=0=--=0=--=0=--=0=--=0=- 167# --==---==---==---==---==---==---==---==---==---==---==---==-- 168 169sub Usage { 170 171 print <<EOF; 172Usage: $ProgramName command[,command,..] [options...] [files|dirs|regexps|...] 173 174Commands (with shorter aliases, they may also be abbreviated to uniqueness): 175 list|ls [regexp] List packages in $StowDir. 176 checkstow|cs [regexp] Check packages in $StowDir. 177 checktarget|ct [regex] Check targetdir for (invalid) files. 178 install dir|file Does untar, make, makeinst, checksums, checkin. 179 untar file Un-tar file. 180 confhelp dir|file Call 'configure --help' from dir|file. 181 make|mk dir Call 'configure' and 'make' in dir. 182 makeinst|mkin dir Call 'make install' in dir. 183 checksums regexp Create checksums of package. 184 chkchksums regexp Check checksums of package. 185 showconfig regexp Show configuration for package if available. 186 depends regexp Create dependencies. 187 checkin|ci regexp Call 'stow' for package. 188 checkout|co regexp Call 'stow -D' for package. 189 rebuild Rebuild whole stow archive. 190 strip regexp Strip files of package. 191 rename regexp new Rename package from old to new. 192 exchange oldpack newpack Exchange (check in and out) two packages. 193 remove|rm regexp Remove/Delete package from $StowDir. 194 instpack file Install package created with 'package'. 195 package regexp Create a package. 196 contents regexp List contents for packages. 197 contsearch regexp Content search in package (see --contentpattern). 198 checklibs regexp Check if all libs for package are available. 199 shell Calls a shell (\$SHELL) with all env-vars set. 200 help|hlp This help screen. 201 config|cfg|cnf Print configuration. 202 version Print version information. 203 204Options (may be abbreviated to uniqueness): 205 -s, --stowdir dir Stow dir, usually '/usr/local/stow'. 206 -t, --targetdir dir Target dir, usually '/usr/local'. 207 --stowname name Name of the stow directory, usually 'stow'. 208 -p, --packagename name Alternate package name. 209 -a, --allpackages Proceed all packages found in $StowDir. 210 -r, --rotatinginstall Loop over the packages to 211 install as long as possible. 212 -v, --verbose level Verbose mode. 213 -q, --quiet Quiet mode. 214 -f, --force Force certain operations. 215 -k, --continue Continue after error if possible. 216 -d, --dumpdir dir Dir to store all the stuff, currently '$DumpDir'. 217 -m, --ambiguous Regexps may match more than one package. 218 -n, --dryrun Only show what to do (as far as possible). 219 -j, --paralleljobs [nr] Number of parallel jobs for make. 220 -c, --configfile file Specify a configfile (may be used multiple times). 221 -o, --outputfile file Output file, default STDOUT. 222 -l, --logfile file Log file, prints short messages, def. /dev/null. 223 --subdir name Specify subdir inside target to install to. 224 --contentpattern pattern Search pattern: '$ContentSearchPattern'. 225 --contentsearchfile file Filelist of matches: '$ContentSearchFile'. 226 --configdirname dirname Name for the configuration directory. 227 --dependencyfilename file Filename for dependencies: '$DependencyFileName'. 228 --checksumfilename file Filename for checksums: '$ChecksumFileName'. 229 --creatorinfofilename file Filename for creatorinfo: '$CreatorInfoFileName'. 230 --packagesuffix string Additional name for packages (e.g. architecture). 231 --use-saved-options Use options from previously installed version. 232 --[no]removesource Do [not] remove unpacked source after built. 233 --no-install-info Don't manage info files via 'install-info'. 234 --prog key=program Specify alternate programs. 235 For keys see \%Progs when doing \`$ProgramName config\'. 236 --prm-conf regexp=param | param 237 --prm-make regexp=param | param 238 Specify extra parameters for the call of 239 configure and make. 240 _ 241 --[no]makecheck, --[no]configure, --[no]make \\ Switch these 242 --[no]depends, --[no]checkin, --[no]strip, > options 243 --[no]chkchksums, --[no]checksums _/ on or off. 244 245 246 List command: I ... Installed, s ... Can be checked in (no conflict), 247 - ... Cannot be checked in (first conflicting file in paranthesis) 248 Check command: see list command plus package size in KB\'s plus 249 X ... package broken (conflicts in paranthesis) 250EOF 251} 252 253sub ShortUsage { 254 print <<EOF; 255Usage: $ProgramName command [options ...] [files|dirs|regexps|...] 256 Use "$ProgramName help" for further help! 257EOF 258} 259 260sub Init { 261 262 # switch buffering off 263 $| = 1; 264 265 # set umask 266 umask $Umask; 267 268 unless (open STDOUT, ">$OutputFile") { 269 print STDERR "Error opening output stream!\n"; 270 exit 1; 271 } 272 273 unless (open LOG, ">$LogFile") { 274 print STDERR "Error opening logfile $LogFile for writing!\n"; 275 exit 1; 276 } 277 LOG->autoflush(); # switch off buffering 278 279 sub unshift_env_vars { 280 my ($name, $s, $deli) = @_; 281 my @e; 282 @e = split(/$deli/, $ENV{$name}) if defined $ENV{$name}; 283 $ENV{$name} = join($deli, $s, @e); 284 } 285 286 my $LIBPATH_ENVVAR = 'LD_LIBRARY_PATH'; 287 # the documentation of LIBPATH (ld(1)) could be interpreted in such a way 288 # that we need to add /usr/lib:/lib to LIBPATH as well if we set it 289 # but I'm not sure about it; on the other way -L call will be used anyway 290 $LIBPATH_ENVVAR = 'LIBPATH' if lc(getSystem()) eq 'aix'; 291 292 # set PATH and LD_LIBRARY_PATH so that you can try out software more 293 # easily in /tmp or so... 294 unshift_env_vars('PATH', $TargetDir.'/bin', ':'); 295 unshift_env_vars($LIBPATH_ENVVAR, $TargetDir.'/lib', ':'); 296 unshift_env_vars('LD_RUN_PATH', $TargetDir.'/lib', ':'); 297 298 # and give "configure" and "make" some hints where to find your stuff 299 #unshift_env_vars('CFLAGS', "-O2", ' '); 300 unshift_env_vars('LDFLAGS', "-L$TargetDir/lib", ' '); 301 unshift_env_vars('CPPFLAGS', "-I$TargetDir/include", ' '); 302} 303 304sub EndWork() { 305 306 FinishLdconfig(); 307 308 close STDOUT; 309 close LOG; 310} 311 312sub printLOG { 313 print LOG @_ if !$DryRun; 314} 315 316sub printV1 { 317 print @_ if $Verbose; 318} 319 320sub printV2 { 321 print @_ if $Verbose > 1; 322} 323 324sub CheckAmbiguousCommand { 325 my $cmd = shift; 326 my @c = grep(/^$cmd/, @Commands, keys %CommandAliases); 327 if ($#c == 0) { 328 return((defined $CommandAliases{$c[0]})?$CommandAliases{$c[0]}:$c[0]); 329 } else { 330 my @d = grep(/^$cmd$/, @c); 331 if ($#d == 0) { 332 return((defined $CommandAliases{$d[0]})?$CommandAliases{$d[0]}:$d[0]); 333 } 334 } 335 print "--> Command `$cmd' is ambiguous.\n" if ($#c > 0); 336 print "--> No such command `$cmd'.\n" if ($#c == -1); 337 undef; 338} 339 340sub GetParams { 341 342 ShortUsage(),exit(1) unless ($ARGV[0]); 343 @Command = split(/,/, shift @ARGV); # split and remove command from ARG's 344 for(my $i = 0; $i <= $#Command; $i++) { 345 ShortUsage(), exit(1) unless 346 (defined ($Command[$i] = CheckAmbiguousCommand(lc($Command[$i])))); 347 } 348 349 $Verbose = undef; 350 my $quiet = undef; 351 my $stowdir = undef; 352 my $targetdir = undef; 353 my @prm_conf = undef; 354 my @prm_make = undef; 355 my @AltProgs; 356 my @opts = ("stowname|stowdirname=s", \$StowDirName, 357 # may also use the + for increasing the level 358 "verbose|v:i", \$Verbose, 359 "dependencyfilename=s", \$DependencyFileName, 360 "checksumfilename=s", \$ChecksumFileName, 361 "packagename|p=s", \$PackageName, 362 "allpackages|a", \$ProceedAllPackages, 363 "quiet|q!", \$quiet, 364 "dumpdir|d=s", \$DumpDir, 365 "contentpattern=s", \$ContentSearchPattern, 366 "contentsearchfile=s", \$ContentSearchFile, 367 "removesource!", \$RemoveSource, 368 "checkin!", \$BoolCheckIn, 369 "depends!", \$BoolDepends, 370 "checksums!", \$BoolChecksums, 371 "chkchksums!", \$BoolCheckChecksums, 372 "ambiguous|multiple|m!", \$Ambiguous, 373 "strip!", \$BoolStrip, 374 "prog=s@", \@AltProgs, 375 "dryrun|n!", \$DryRun, 376 "prm-conf=s@", \@prm_conf, 377 "prm-make=s@", \@prm_make, 378 "logfile|l=s", \$LogFile, 379 "outputfile|o=s", \$OutputFile, 380 "continue|k!", \$Continue, 381 "packagesuffix=s", \$PackageSuffix, 382 "configure!", \$BoolConfigure, 383 "make!", \$BoolMake, 384 "makecheck!", \$BoolMakeCheck, 385 "rotateinstall|r!", \$BoolRotateInstall, 386 "creatorinfofilename=s", \$CreatorInfoFileName, 387 "configdirname=s", \$ConfigDirName, 388 "force|f!", \$BoolForce, 389 "subdir=s", \$SubDirName, 390 "paralleljobs|j:i", \$ParallelJobs, 391 "use-saved-options!", \$BoolUseSavedOptions, 392 "no-install-info!", \$BoolNoInstallInfo, 393 ); 394 my @opts_stowtargetdir = ("stowdir|s=s", \$stowdir, 395 "targetdir|t=s", \$targetdir 396 ); 397 my @opts_configfile = ("configfile|c=s@", \@ConfigFiles); 398 399 400 # the options from the environment variable 401 my @env_options = 402 (exists $ENV{$ENV_STOWES})?(split /\s/, $ENV{$ENV_STOWES}):(); 403 404 # the options given on the command line 405 my @orig_argv = @ARGV; 406 407 Getopt::Long::config("pass_through"); 408 # get the config-files from the environment variable 409 @ARGV = @env_options; 410 my $ret = GetOptions(@opts_configfile); 411 @env_options = @ARGV; # env_options now without the -c option 412 $ret || (ShortUsage(), exit(1)); # useless here? 413 414 # get the config-files from the command line 415 @ARGV = @orig_argv; 416 $ret = GetOptions(@opts_configfile); 417 @orig_argv = @ARGV; # @orig_argv now without the -c option 418 419 420 # now check the config-files for the existance of 421 # stowdir and targetdir options 422 @ARGV = ReadConfigFile(@rcFiles, @ConfigFiles); 423 $ret = GetOptions(@opts_stowtargetdir); 424 my @config_options = @ARGV; # without the "-s" and "-t" options 425 $ret || (ShortUsage(), exit(1)); # useless here? 426 # save them 427 my $configfile_stowdir = $stowdir; 428 my $configfile_targetdir = $targetdir; 429 $stowdir = $targetdir = undef; 430 431 432 # now check the env-var for the existance of 433 # stowdir and targetdir options 434 if ($#env_options != -1) { 435 @ARGV = @env_options; 436 $ret = GetOptions(@opts_stowtargetdir); 437 @env_options = @ARGV; # without the "-s" and "-t" options 438 $ret || (ShortUsage(), exit(1)); # useless here? 439 } 440 my $env_stowdir = $stowdir; 441 my $env_targetdir = $targetdir; 442 $stowdir = $targetdir = undef; 443 444 # read all the options from the command-line 445 Getopt::Long::config("no_pass_through"); 446 @ARGV = (@config_options, @env_options, @orig_argv); # order matters here! 447 $ret = GetOptions(@opts_stowtargetdir, @opts); 448 $ret || (ShortUsage(), exit(1)); 449 450 $Verbose = (!defined $Verbose)?1:(!$Verbose)?2:($Verbose+1); 451 $Verbose = 0 if (defined $quiet && $quiet); 452 453 printV2("Using Stow-/TargetDir from "); 454 unless ($stowdir || $targetdir) { # no -s or -t on command-line 455 if ($env_stowdir || $env_targetdir) { 456 $stowdir = ($env_stowdir)?($env_stowdir):undef; 457 $targetdir = ($env_targetdir)?($env_targetdir):undef; 458 printV2 "environment variable \$$ENV_STOWES.\n"; 459 } else { 460 $stowdir = $configfile_stowdir; 461 $targetdir = $configfile_targetdir; 462 printV2(($configfile_stowdir || $configfile_targetdir)? 463 ("config-files.\n"):("built-in values.\n")); 464 } 465 } else { 466 printV2 "command line.\n"; 467 } 468 469 $stowdir = UnTildePath($stowdir) if defined $stowdir; 470 $targetdir = UnTildePath($targetdir) if defined $targetdir; 471 472 my $cwd = getcwd(); # cache cwd 473 if (defined $targetdir) { 474 ($TargetDir = RelToAbsPath($cwd, $targetdir)) =~ s,/*$,,; 475 $StowDir = (defined $stowdir)? 476 RelToAbsPath($cwd, $stowdir):$TargetDir."/".$StowDirName; 477 } elsif (defined $stowdir) { 478 $StowDir = RelToAbsPath($cwd, $stowdir); 479 $TargetDir = GetParentDir($StowDir); 480 } 481 482 $DumpDir = RelToAbsPath($cwd, UnTildePath($DumpDir)); 483 484 # remove trailing "/"'s 485 $StowDir =~ s,/*$,,; 486 $TargetDir =~ s,/*$,,; # just to go for sure... 487 $DumpDir =~ s,/*$,,; 488 489 # remove to much slashes 490 $SubDirName =~ s,/+,/,g; 491 $SubDirName =~ s,^/*(.*?)/*$,$1,; 492 # prepend a slash so that $SubDirName is directly insertable 493 $SubDirName = '/'.$SubDirName if ($SubDirName ne ''); 494 495 for (@AltProgs) { 496 my @a = split(/=/, $_, 2); 497 next unless (defined $a[0] && defined $a[1]); 498 ShortUsage(),exit(1) unless (grep(/^$a[0]$/, keys %Progs)); 499 $Progs{$a[0]} = $a[1]; 500 } 501 502 sub __split_param_stuff { 503 my %r; 504 for (@_) { 505 next unless defined; 506 my @a = split /=/, $_, 2; 507 if ($#a == 0) { $a[1] = $a[0]; $a[0] = ''; } 508 509 $r{$a[0]} .= ((defined $r{$a[0]})?' ':'').$a[1]; 510 } 511 %r; 512 } 513 514 %ParamConfigure = __split_param_stuff(@prm_conf); 515 %ParamMake = __split_param_stuff(@prm_make); 516 517 $ParallelJobs = 1 if $ParallelJobs < 0; 518 519 printV2 "Values: TargetDir \"$TargetDir\" and StowDir \"$StowDir\".\n", 520 "Dumping files into \"$DumpDir\".\n"; 521 522 1; 523} 524 525sub CheckForExternalPrograms { 526 # check for all programs in %Progs whether they're available 527 my @p = map {UnTildePath($_)} split(/:/, $ENV{PATH}); 528 for (keys %Progs) { 529 my $bin = (split(/\s+/, $Progs{$_}))[0]; 530 print "Checking for $bin ... " if $Verbose >= 3; 531 my $bo = 0; 532 $bo = 1 if $bin =~ /^\// && -x $bin; 533 unless ($bo) { 534 for my $p (@p) { $bo = 1,last if -x $p.'/'.$bin; } 535 } 536 if ($bo) { 537 print "found.\n" if $Verbose >= 3; 538 } else { 539 if (defined $ProgsFailFuncs{$_}) { 540 &{$ProgsFailFuncs{$_}}; 541 } else { 542 die "Could not find program \"$bin\"!\n". 543 " Please install it or cheat me with the `--prog'-param.\n"; 544 } 545 } 546 } 547} 548 549sub ReadConfigFile { 550 my @args = (); 551 foreach my $f (@_) { 552 $f = UnTildePath($f); 553 open(FF, $f) || next; 554 while (defined ($_ = <FF>)) { 555 s/(.*)\#.*/$1/; 556 $_ = CutOffWhitespaces($_); 557 next if /^$/; 558 push @args, split(/\s/); 559 } 560 close FF; 561 } 562 @args; 563} 564 565sub CutOffWhitespaces { 566 $_ = $_[0]; 567 s/^\s*(.*?)\s*$/$1/; # cut off whitespaces 568 $_; 569} 570 571sub PrintValuesInString { 572 my ($name, $ref) = @_; 573 return unless (defined $ref); 574 my $s; 575 $s .= "$name = " if (defined $name); 576 if (ref $ref eq "ARRAY") { 577 $s .= "[ ".join(', ', @{$ref})." ]"; 578 } elsif (ref $ref eq "HASH") { 579 $s .= "{ ". join(', ', map {"$_ => \"$$ref{$_}\""} keys(%{$ref})). " }"; 580 # $s .= "{ ". join(', ', map {"$_ => ".((ref $$ref{$_} eq "ARRAY")?PrintValuesInString(undef, \@{$$ref{$_}}):$$ref{$_}) } keys(%{$ref})). " }"; 581 } else { 582 $s .= ((defined $$ref)?"'$$ref'":"undef"); 583 } 584 $s; 585} 586 587sub PrintValues { 588 print PrintValuesInString(@_); 589} 590 591sub AreRegExpMatching { 592 my ($file, $what, $index_pos, @re) = @_; 593 foreach ( @re ) { 594 if ($what) { 595 # use real regexps 596 return 1 if ($file =~ /$_/i); 597 } else { 598 if (defined $index_pos && $index_pos >= 0) { 599 return 1 if (index($file, $_) == $index_pos); 600 } else { 601 return 1 if (index($file, $_) != -1); 602 } 603 } 604 } 605 0; 606} 607 608sub GetParamsForPrograms { 609 my ($package, %Params) = @_; 610 my $p = ''; 611 for (keys %Params) { 612 $p .= $Params{''},next if ($_ eq ''); 613 $p .= ($package =~ /$_/i)?$Params{$_}.' ':''; 614 } 615 $p; 616} 617 618sub GetParamsForMake { GetParamsForPrograms(shift, %ParamMake); } 619sub GetParamsForConfigure { GetParamsForPrograms(shift, %ParamConfigure); } 620 621sub GetParallelParamForMake { 622 if ($ParallelJobs == 0) { 623 return "-j".getCPUNumber(); 624 } elsif ($ParallelJobs > 1) { 625 return "-j$ParallelJobs"; 626 } 627 return ''; 628} 629 630sub FollowLink { 631 my $lnk = shift; 632 my $nlnk; 633 while (defined ($nlnk = readlink($lnk))) { 634 $lnk = $nlnk; 635 } 636 $lnk; 637} 638 639sub getSystem { 640 my $sys = `uname -s 2>&1`; 641 return undef if $?; 642 chomp $sys; 643 return $sys; 644} 645 646sub getCPUNumber { 647 my $default_nr = 1; 648 my $nr = 0; 649 650 # try some methods to get the number 651 my $sys = getSystem(); 652 return $default_nr unless defined $sys; 653 654 if (lc($sys) eq 'linux') { 655 # Linux with mounted /proc (should be usual) 656 if (-r "/proc/cpuinfo") { 657 open(A, "/proc/cpuinfo") || return $default_nr; 658 while (<A>) { 659 $nr++ if (/^processor\s+:/); 660 } 661 close A; 662 } 663 } elsif (lc($sys) eq 'aix') { 664 if (open(A, "lsdev -C |")) { 665 while (<A>) { 666 $nr++ if (/^proc\d+\s+Available.+Processor/); 667 } 668 close A; 669 } 670 } elsif (lc($sys) eq 'sunos') { 671 if (open(A, "mpstat |")) { 672 while (<A>) { 673 $nr++ if (/^\s*\d/); 674 } 675 } 676 } 677 678 return (($nr)?($nr):$default_nr); 679} 680 681sub NetGet { 682 my ($url) = @_; 683 my $file = GetBaseName($url); 684# return 1 if (is_success(getstore($url, $file))); 685 0; 686} 687 688# DiveDir 689 690# $path ... path to begin 691# $file_sub ... sub called for every not-dir found (with the name as param) 692# $dir_sub ... sub called for every dir found (with the name as param) 693# $attrs ... hash of values: 694# A default may be given in parentheses if none is given the option 695# has to be supplied. 696# - Dive ... true/1: go recursively 697# false/0: process only files/dirs in $path 698# - RegExpIncl([]) ... RegExp(s) for names to include as an array 699# if nothing is given "all" is assumed 700# - RegExpExcl([]) ... RegExp(s) for names to exclude as an array 701# excludes are checked after the includes 702# - CheckWithPath(0) ... true/1: Check whole path against regexps 703# false/0: Only check "basename" against regexps 704# - RealRegExp(1) ... true/1: Use real regexps for checking 705# false/0: Use index function for checking (faster?) 706# (this is necessary for using filenames with special chars as 707# search expressions (e.g. gtk+ is a candidate here...)) 708# - IndexPos(undef) ... Used if "RealRegExp"-Option is false 709# if not set (undef) than the searchstring can 710# match somewhere, if a position is set, the found 711# substring has to start at this position, 0 is the 712# first one (see index function in perlfunc) 713# THE LAST TWO ONES SEEM TO BE BROKEN OF CONCEPT... :-( 714# - Continue(0) ... true/1: you want to go on even if a sub fails 715# or the return value of the sub is not 716# interesting to you... 717# false/0: exit immediately if a sub 718# returns someting != undef 719# - FollowLinks(0) ... true/1: Follow (directory!) links 720# (infinite loops may occur!) 721# false/0: Don't follow (directory) links 722# Example: 723# DiveDir("/usr/local/stow", \&mydel, \&mydel, 724# {Dive => 0, RegExpExcl => ["^stow\$"]}); 725# sub mydel { `rm -rf $_[0]`; } 726 727# these are the default-values for the options 728my %DiveDir_DefaultOptionValues = 729 ( CheckWithPath => 0, 730 RealRegExp => 1, 731 IndexPos => undef, 732 Continue => 0, 733 FollowLinks => 0, 734 RegExpIncl => [], 735 RegExpExcl => [], 736 ); 737my @DiveDir_MustBeGivenOptions = ('Dive'); 738 739sub DiveDir { 740 my ($path, $file_sub, $dir_sub, $attrs) = @_; 741 742 # remove trailing slashes 743 $path =~ s/(.*?)\/*$/$1/; 744 745 if ($DEV) { 746 # must options 747 foreach (@DiveDir_MustBeGivenOptions) { 748 die "$_-option not specified for DiveDir!" unless exists $$attrs{$_}; 749 } 750 751 # check for validity 752 foreach my $k (keys %$attrs) { 753 die "Unknown option \"$k\" in DiveDir!" 754 unless (grep(/^$k$/, @DiveDir_MustBeGivenOptions, 755 keys %DiveDir_DefaultOptionValues)); 756 } 757 } 758 759 # set std-values of options not given 760 foreach (keys %DiveDir_DefaultOptionValues) { 761 $$attrs{$_} = $DiveDir_DefaultOptionValues{$_} 762 unless (defined $$attrs{$_}); 763 } 764 765 DiveDirSub($path, $file_sub, $dir_sub, $attrs); 766} 767 768sub DiveDirSub { 769 my ($path, $file_sub, $dir_sub, $attrs) = @_; 770 my $entry; 771 my $ret = undef; 772 my $dh; 773 774 opendir($dh, $path) || die "Can't open directory $path: $!"; 775 foreach ( sort readdir($dh) ) { 776 next if (/^\.{1,2}$/); 777 $entry = $path."/".$_; 778 779 next unless (!@{$$attrs{RegExpIncl}} || 780 $#{$$attrs{RegExpIncl}} == -1 || 781 AreRegExpMatching(($$attrs{CheckWithPath})?$entry:$_, 782 $$attrs{RealRegExp}, 783 $$attrs{IndexPos}, 784 @{$$attrs{RegExpIncl}})); 785 next if (@{$$attrs{RegExpExcl}} && 786 $#{$$attrs{RegExpExcl}} != -1 && 787 AreRegExpMatching(($$attrs{CheckWithPath})?$entry:$_, 788 $$attrs{RealRegExp}, 789 $$attrs{IndexPos}, 790 @{$$attrs{RegExpExcl}})); 791 792 $ret = &$file_sub($entry) if (defined($file_sub) && ! -d $entry); 793 $ret = &$dir_sub($entry) if (defined($dir_sub) && -d $entry); 794 795 if ($$attrs{Dive} && (!defined $ret || $$attrs{Continue}) && 796 -d $entry && ($$attrs{FollowLinks} || ! -l $entry)) { 797 if (-r $entry) { 798 $ret = DiveDirSub($entry, $file_sub, $dir_sub, $attrs); 799 } else { 800 print "WARNING: $entry not readable!\n" if $Verbose; 801 } 802 } 803 return $ret if (!$$attrs{Continue} && defined $ret); 804 } 805 closedir $dh; 806 undef; 807} 808 809 810 811# ---------------------------------------- 812 813# calls a program, 814# returns 1 if program outputs nothing (success) 815# returns 0 if program outputs something (failure) 816sub CallSilent { 817 my ($start_text, $exec_text, $print_output, $error_text, $end_text) = @_; 818 819 if ($DryRun) { 820 print "($exec_text)\n"; 821 return 1; 822 } 823 print $start_text if defined $start_text; 824 my $output = `$exec_text 2>&1`; 825 if (defined $error_text && $output ne '') { 826 print $error_text; 827 print $output if ($print_output); 828 return 0; 829 } 830 print $end_text if defined $end_text; 831 1; 832} 833 834# calls a program 835# returns 1 (success) if the program returned with exit code 0 836# returns 0 (failure) if the program returns with exit code != 0 837# prints error message when exit code of program is != 0 838sub CallExitCode { 839 my ($start_text, $exec_text, $error_text, $end_text) = @_; 840 841 if ($DryRun) { 842 print "($exec_text)\n"; 843 return 1; 844 } 845 print $start_text if (defined $start_text); 846 system($exec_text); 847 my $status = $? >> 8; 848 print $error_text if (defined $error_text && $status); 849 print $end_text if (defined $end_text); 850 !$status; 851} 852 853# calls a program 854# returns 1 if $scan_pattern could not be matched on the output of the program 855# returns 0 if $scan_pattern could be found in the output of the program 856sub CallOutput { 857 my ($start_text, $exec_text, $error_text, $scan_pattern, $end_text) = @_; 858 859 if ($DryRun) { 860 print "($exec_text)\n"; 861 return 1; 862 } 863 my $err = 1; 864 printV1 $start_text if defined $start_text; 865 unless (open(F, "$exec_text 2>&1 |")) { 866 printV1 $error_text if defined $error_text; 867 return 0; 868 } 869 while (<F>) { 870 print; 871 $err = 0 if defined $scan_pattern && $scan_pattern ne '' && 872 /$scan_pattern/i; 873 } 874 close F; 875 printV1 $end_text if defined $end_text; 876 $err; 877} 878 879# ----- ----- ----- ----- 880 881sub CopyFile { # why not use cp? 882 my ($from, $to) = @_; 883 printV1("cp $from $to.\n"), return(1) if ($DryRun); 884 885 open(INP, "$from") || (printV1("Error opening file $from."), return 0); 886 open(OUTP, ">$to") || (printV1("Error creating file $to."), return 0); 887 while (<INP>) { print OUTP $_; } 888 close(OUTP); 889 close(INP); 890 1; 891} 892 893# this sub will do a "mkdir -p $path" 894sub MkDir { 895 my ($path, $rights) = @_; 896 return 1 unless ($path =~ /^\//); 897 if ($DryRun) { 898 printV1("mkdir -p $path ", 899 (defined $rights)?"with rights $rights (relative to umask)":"", 900 "\n"); 901 return 1; 902 } 903 904 my @spl = split("/", $path); 905 my $p = ""; 906 for (@spl[1 ..$#spl]) { 907 $p .= "/".$_; 908 next if (-d $p); 909 unless (mkdir($p, (defined $rights)?$rights:0777)) { 910 printV1 "Could not create directory $p!\n"; 911 return 0; 912 } 913 } 914 1; 915} 916 917sub Uniq { 918 my (@data) = @_; # date should be sorted 919 920 my $i = 0; 921 while ($i < $#data) { 922 if ($data[$i] eq $data[$i+1]) { 923 splice(@data, $i, 1); 924 next; 925 } 926 $i++; 927 } 928 @data; 929} 930 931sub ExcludeLibs { 932 my (@libs) = @_; # array should be preprocessed by sort und Uniq... 933 934 my $i = 0; 935 my $bo; 936 while ($i <= $#libs) { 937 $bo = 0; 938 foreach my $pattern ( @exclude_dep_libs ) { 939 $bo = 1, last if ($libs[$i] =~ /$pattern/); 940 } 941 if ($bo) { 942 splice(@libs, $i, 1); 943 } else { 944 $i++; 945 } 946 } 947 @libs; 948} 949 950# this is not generally right, but will work for the needs it's used... 951sub IsRuleInMakefile { 952 my ($rule, $makefile) = @_; 953 954 open(F, $makefile) || return 0; 955 while (defined($_ = <F>)) { 956 close(F),return(1) if (/^$rule:/); 957 } 958 close F; 959 0; 960} 961 962sub CheckDir { 963 my ($path, $p) = @_; 964 965 return 1 if ($DryRun || -d $path); 966 printV1 "There is no directory $path!\n" if (!defined $p || !$p); 967 0; 968} 969 970sub RelToAbsPath { 971 my ($wd, $relpath) = @_; 972 973 return $relpath if ($relpath =~ /^\//); 974 return undef if ($wd !~ /^\//); 975 976 my @relparts = split('/', $relpath); 977 my @wdparts = split('/', $wd); 978 shift(@wdparts); 979 980 my $i = $#wdparts; 981 for (@relparts) { 982 $i--,next if ($i != -1 && $_ eq '..'); 983 next if ($_ eq '.' || $_ eq '..'); 984 $wdparts[++$i] = $_; 985 } 986 "/".join('/', @wdparts[0..$i]); 987} 988 989sub UnTildePath { 990 ($_ = shift) =~ s,^~([^/]*),($1 eq '')?$ENV{HOME}:(@_=(getpwnam $1))?$_[7]:"~$1",e; 991 $_; 992} 993 994sub GetFirstDirFromTar { 995 my ($tarfile, $prefilter) = @_; 996 997 unless (open(F, "$prefilter $tarfile |")) { 998 printV1 "Problems getting directory name from $tarfile!"; 999 return undef; 1000 } 1001 my $name = <F>; 1002 close(F); 1003 substr($name, 0, index($name, "/")); 1004} 1005 1006sub getDottedFigure { 1007 ($_) = @_; 1008 # get thousands_sep info from locale, 1009 # I'm taking the monetary value here and I'm ignoring the 1010 # grouping value 1011 my ($thousands_sep) = @{localeconv()}{'mon_thousands_sep'}; 1012 $thousands_sep = ',' unless defined $thousands_sep; 1013 my $ts_pat = ($thousands_sep eq '.')?'\\.':$thousands_sep; 1014 while(s/(\d)(\d{3}($ts_pat|$))/$1$thousands_sep$2/) {} 1015 $_; 1016} 1017 1018# this sub checks the status of a package 1019# it may return: 1020# - not checked in (really no file found) 1021# - partionally checked in/broken (only some files are checked in) 1022# - checked in (all files are checked in) 1023sub PACKAGE_CHECKEDIN { 1; } 1024sub PACKAGE_CHECKEDOUT { 2; } 1025sub PACKAGE_BROKEN { 3; } 1026sub GetPackageStatus { 1027 my $package = shift; 1028 1029 my $package_path = $StowDir.'/'.$package; 1030 my $plength = length($package_path) + 1; 1031 my $filecount = 0; 1032 my $files_ok = 0; 1033 my $skip_dir = undef; 1034 my @conflicts = (); 1035 1036 DiveDir($package_path, 1037 sub { # sub for file 1038 my $file = shift; 1039 my $targetlink = $TargetDir.'/'.substr($file, $plength); 1040 my @filestats = lstat($file); 1041 my $leave = 0; 1042 my $link = 0; 1043 if (($filestats[2] & 0120000) == 0120000) { 1044 # $file is a link --> get real stats 1045 $link = 1; 1046 @filestats = stat($file); 1047 } 1048 unless (@filestats) { 1049 push(@conflicts, $file); 1050 $leave = 1; 1051 } 1052 1053 return if (defined $skip_dir && 1054 index($targetlink, $skip_dir) == 0); 1055 $filecount++; 1056 return if $leave; 1057 1058 push(@conflicts, $targetlink),return unless (-l $targetlink); 1059 my $targetfile = readlink($targetlink); 1060 # not checking if targetfile is defined since we have already 1061 # checked that targetlink is a link 1062 $targetfile = RelToAbsPath(GetPathName($targetlink), $targetfile); 1063 my @targetstats = stat($targetfile); 1064 push(@conflicts, $targetfile),return 1065 unless ($#targetstats != -1 && $targetstats[1] == $filestats[1]); 1066 $files_ok++; 1067 }, 1068 sub { # sub for dir 1069 my $dir = shift; 1070 my $targetdir = $TargetDir.'/'.substr($dir, $plength); 1071 return if (defined $skip_dir && index($targetdir, $skip_dir) == 0); 1072 1073 if (-l $targetdir) { 1074 $filecount++; 1075 my $linkdir = 1076 RelToAbsPath(GetPathName($targetdir), readlink($targetdir)); 1077 # not checking if readlink is succesful since targetdir 1078 # is a link inside here... 1079 if ($linkdir eq $dir) { $files_ok++; } 1080 else { push @conflicts, $linkdir; } 1081 } 1082 $skip_dir = (-l $targetdir)?$targetdir.'/':undef; 1083 }, 1084 {Dive=>1, Continue=>1, FollowLinks=>1}); 1085 1086 my $ret; 1087 if ($filecount == $files_ok) { 1088 $ret = PACKAGE_CHECKEDIN; 1089 } elsif ($files_ok == 0) { 1090 $ret = PACKAGE_CHECKEDOUT; 1091 } else { 1092 $ret = PACKAGE_BROKEN; 1093 } 1094 1095 return ($ret, $filecount, $files_ok, @conflicts) 1096 if (wantarray); 1097 return $ret; 1098} 1099 1100 1101# if the package does NOT contain a file this will not work 1102# (but which package does not contain one; at least .config 1103# should be lying around...) 1104# this sub only checks for one file... 1105# and has a flaw, if the package is broken in a way that the 1106# first file which DiveDir gets has no link in the targetdir it 1107# reports that this package isn't checked in although it's checked 1108# in but broken 1109# nevertheless this sub is faster than GetPackageStatus but don't use 1110# it for serious work 1111sub IsStowedIn_simple { 1112 my ($pack_dirname) = @_; 1113 1114 return 0 unless (CheckDir($StowDir."/".$pack_dirname)); 1115 # Lets get a file of this package 1116 my $pfile = my $tfile = 1117 DiveDir($StowDir."/".$pack_dirname, sub { return $_[0]; }, undef, 1118 {Dive => 1}); 1119 return 0 unless (defined $pfile); 1120 1121 # cut off $StowDir/$pack_dirname from file and preceed $TargetDir 1122 $tfile = $TargetDir.substr($tfile, length($StowDir."/".$pack_dirname)); 1123 1124 # check files 1125 return 0 unless (-e $tfile); 1126 # check if $pfile and $tfile are the same 1127 # (will only work on filesystems with inodes...) 1128 return 1 if ( (stat($pfile))[1] == (stat($tfile))[1]); 1129 0; 1130} 1131 1132sub GetPackageSize { 1133 my $package = shift; 1134 1135 my ($sizebytes, $sizeblocks) = (0, 0); 1136 my %hlinodes; 1137 1138 my $filesize = sub { 1139 my @filestats = lstat(shift); 1140 if ($filestats[3] > 1) { # hard links 1141 unless (defined $hlinodes{$filestats[1]}) { 1142 $hlinodes{$filestats[1]}++; 1143 $sizebytes += $filestats[7]; 1144 $sizeblocks += $filestats[12]; 1145 } 1146 } else { 1147 $sizebytes += $filestats[7]; 1148 $sizeblocks += $filestats[12]; 1149 } 1150 }; 1151 1152 &$filesize($StowDir.'/'.$package); 1153 DiveDir($StowDir.'/'.$package, 1154 $filesize, # sub for files 1155 $filesize, # sub for dirs 1156 {Dive => 1, Continue => 1}); 1157 1158 return ($sizebytes, $sizeblocks); 1159} 1160 1161# return "" if the answer is yes and the file conflicting if the 1162# answer is no 1163sub CanPackageBeStowedIn { 1164 my $package = shift; 1165 1166 return "" if (GetPackageStatus($package) == PACKAGE_CHECKEDIN); 1167 1168 my $plength = length("$StowDir/$package") + 1; 1169 my $res = 1170 DiveDir($StowDir."/".$package, 1171 sub { 1172 my $stowfile = shift; 1173 my $targetfile = $TargetDir."/".substr($stowfile, $plength); 1174 return $targetfile if (-f $targetfile); 1175 undef; 1176 }, 1177 undef, 1178 {Dive=>1, FollowLinks=>1}); 1179 return "" unless (defined $res); 1180 return $res; 1181} 1182 1183sub GetBaseName { 1184 my $path = shift; 1185 $path =~ s,/+$,,; 1186 my @spl = split(/\//, $path); 1187 return $spl[$#spl]; 1188} 1189 1190sub GetPathName { 1191 my $path = shift; 1192 $path =~ s,/+$,,; 1193 my @spl = split(/\//, $path); 1194 my $p = join('/', @spl[0..$#spl-1]); 1195 ($p eq '')?'/':$p; 1196} 1197 1198sub GetParentDir { 1199 GetPathName(@_); 1200} 1201 1202sub GetPackageName { 1203 my ($abspath) = @_; 1204 return $PackageName if (defined $PackageName); 1205 GetBaseName($abspath); 1206} 1207 1208sub GetConfigDirForPackage { 1209 my $package = shift; 1210 return "$StowDir/$package/$ConfigDirName/$package"; 1211} 1212 1213sub CreateConfigDirInPackage { 1214 my $package = shift; 1215 return 0 unless (MkDir(GetConfigDirForPackage($package))); 1216 1; 1217} 1218 1219# don't forget to change DoRename if changing sth here... 1220sub CreateCreatorInfoFile { 1221 my $package = shift; 1222 my $file = GetConfigDirForPackage($package).'/'.$CreatorInfoFileName; 1223 printV1("Would create creatorinfo in $file\n"), return 1 if ($DryRun); 1224 1225 my ($user, $gcos) = (getpwuid($<))[0, 6]; 1226 $gcos =~ s/^(.*?),/$1/; 1227 open(CI, ">$file") || return 0; 1228 print CI 1229 "Package : $package\n", 1230 "Creator : ", $user, " ($gcos)\n", 1231 "Date : ", scalar localtime(time), "\n", 1232 # Splitting these up isn't really platform independant 1233 "Host-Info : ", `$Progs{uname} -a`, 1234 "stowES : $Version\n"; 1235 close CI; 1236 1; 1237} 1238 1239sub CheckPackageExistance { 1240 my $package = shift; 1241 if (-d $StowDir."/".$package && !$BoolForce) { 1242 printV1 "$package does already exists!\n"; 1243 return 0; 1244 } 1245 1; 1246} 1247 1248sub CountMatchesInDir { # takes: dir, regexp, regexp, more regexps, ... 1249 my $counter = 0; 1250 DiveDir(shift, sub { $counter++; }, sub { $counter++; }, 1251 {Dive=>0, Continue=>1, FollowLinks=>1, RegExpIncl=>\@_}); 1252 $counter; 1253} 1254 1255sub GetMatchesInDir { # takes: dir, regexp, regexp, more regexps, ... 1256 my @matches = (); 1257 DiveDir(shift, 1258 sub { push @matches, $_[0]; }, 1259 sub { push @matches, $_[0]; }, 1260 {Dive=>0, Continue=>1, FollowLinks=>1, RegExpIncl=>\@_}); 1261 @matches; 1262} 1263 1264 1265sub GetTempFile { 1266 my $dir = shift; 1267 my $prefix = shift; 1268 1269 $dir = $DumpDir unless ($dir); 1270 $dir =~ s,/*$,/,; 1271 $prefix = "" unless (defined $prefix); 1272 my $file = undef; 1273 my $f; 1274 1275 for my $c ( 1 .. 50 ) { 1276 $f = $dir.$prefix."_temp_$c"."_".time(); 1277 unless (-e $f) { 1278 $file = $f; 1279 last; 1280 } 1281 } 1282 unless (defined $file) { 1283 printV1 "Couldn't create temporary file, giving up!"; 1284 return undef; 1285 } 1286 $file; 1287} 1288 1289sub ReplaceInFile { 1290 my ($file, $from, $to) = @_; 1291 1292 printV1("Replacing \"$from\" in file \"$file\" to \"$to\".\n"), return(1) 1293 if $DryRun; 1294 1295 -r $file || (printV1("Cannot read file $file!\n"), return 0); 1296 1297 my $tempfile = GetTempFile(GetPathName($file), $ChecksumFileName); 1298 return 0 unless ($tempfile); 1299 1300 open(RF, $file) || 1301 (printV1("Could not open file $file for reading!\n"), return 0); 1302 open(WF, ">$tempfile") || 1303 (printV1("Could not open file $tempfile for writing!\n"), return 0); 1304 while (defined ($_ = <RF>)) { 1305 s/$from/$to/g; 1306 print WF; 1307 } 1308 close WF; 1309 close RF; 1310 1311 unlink($file) || (printV1("Could not delete file $file!\n"), return 0); 1312 rename($tempfile, $file) || 1313 (printV1("Could not rename $tempfile to $file!\n"), return 0); 1314 1; 1315} 1316 1317# give a file (with full absolute path) and get the package it belongs to; 1318# return undef if no package could be found 1319sub GetPackageNameForFile { 1320 $_ = shift; 1321 return undef unless (s,^$StowDir/,,); 1322 return (split(/\//))[0]; 1323} 1324 1325# this sub checks the targetdir only contains links and dirs (1) 1326# and that the links are pointing into the $StowDir (2) 1327# (1) ... if not the files/dirs are prefixed with "f:" 1328# (2) ... if not -"- -------------- " ---------- "o:" 1329sub CheckTargetDir { 1330 my @err_files_and_dirs = (); 1331 1332 DiveDir($TargetDir, 1333 sub { # files 1334 my $file = shift; 1335 1336 my $real = readlink $file; 1337 if (defined $real) { 1338 # check link here 1339 if (index(RelToAbsPath(GetPathName($file), $real), 1340 $StowDir) == -1) { 1341 push @err_files_and_dirs, "o:".$file; 1342 } 1343 } else { 1344 push @err_files_and_dirs, "f:".$file; 1345 } 1346 }, 1347 undef, 1348 {Dive=>1, CheckWithPath=>1, RealRegExp=>1, Continue=>1, 1349 RegExpExcl => ["^$StowDir\$"]}); 1350 1351 return (wantarray)?@err_files_and_dirs:($#err_files_and_dirs+1); 1352} 1353 1354# get configuration options of package out of store "config.status" files 1355# given back as a string, undef if file couldn't be opened 1356sub GetPackageConfiguration { 1357 my $package = GetBaseName(shift); 1358 1359 return undef 1360 unless (open(C, GetConfigDirForPackage($package).'/config.status')); 1361 1362 # this is highly dependant on the layout of 1363 # the config.status file of autoconf 1364 1365 my $d = $/; 1366 undef $/; 1367 # suck whole file in this variable so that we can apply a regexp on it 1368 $_ = <C>; 1369 close C; 1370 $/ = $d; 1371 1372 # config.status-layout by autoconf < 2.5 1373 return $1 1374 if /# on host \S+:.#.#\s+\S+configure\s+(.+?)$/smi; 1375 1376 # layout used by autoconf >= 2.5 1377 return $1 1378 if /config\.status.*?^configured by .+?configure, generated by GNU Autoconf .+?,. with options \\\"(.*?)\\\"$/smi; 1379 1380 # this is e.g. found in gcc, neglecting the possible path issue of the 1381 # configure call 1382 return $1 1383 if /^\S+\/configure\s+(.+?)$/mi; 1384 1385 '__NONE__'; 1386} 1387 1388sub GetTarfileDecompressor { 1389 my $file = shift; 1390 1391 if ($file =~ /\.t?gz$/) { 1392 return "$Progs{gzip} -cd"; 1393 } elsif ($file =~ /\.bz2$/) { 1394 return "$Progs{bzip2} -cd"; 1395 } elsif ($file =~ /\.tar$/) { 1396 return $Progs{cat}; 1397 } else { 1398 printV1("Unsupported format for $file!\n"); 1399 return undef; 1400 } 1401} 1402 1403sub RegisterInfoDocumentation { 1404 my $package = GetPackageName(shift); 1405 1406 # this is not ready yet... 1407 1408 #if (! -e "$TargetDir/info/dir" || -f "$TargetDir/info/dir") { 1409 # `$Progs{'install-info'} --infodir=$TargetDir/info `; 1410 #} 1411 # 1412 1413 DiveDir("$StowDir/$package/$InfoDir", 1414 sub { 1415 1416 }, 1417 undef, 1418 {RegExpIncl => ['\.info(\.gz)?$']}); 1419 1420} 1421 1422sub UnregisterInfoDocumentation { 1423 1424} 1425 1426# find an older configuration for a given file using some "magic" 1427# to get the latest installed package 1428sub GetSavedOptionsFromOlderPackage { 1429 my $package = GetPackageName(shift); 1430 1431 # the version of the "old" package and the package we're just installing 1432 # will usually be different, so we'll have to find an appropriate base 1433 # name to choose the old configuration from... 1434 my $basename = $package; 1435 1436 my @b = split //, $basename; 1437 1438 my $start_block = 0; 1439 my $cont_block = 0; 1440 my $regexp = '\d'; 1441 my $version_start = 0; 1442 for (my $i = 0; $i <= @b; $i++) { 1443 $version_start = 1 1444 if (defined $b[$i] && $b[$i] !~ /[\w\d]/); 1445 1446 if ($version_start && defined $b[$i] && $b[$i] =~ /$regexp/) { 1447 $start_block = $i unless $start_block; 1448 } elsif ($start_block) { 1449 splice(@b, $start_block, $i-$start_block, 1450 ($cont_block)?'[\w\d]*':'\d+'); 1451 $cont_block++; 1452 $regexp = '[\d\w]'; 1453 $i = $start_block+1; 1454 $start_block = 0; 1455 } 1456 } 1457 1458 $basename = join('', @b); 1459 1460 # - now, that we've got the basename of the package we can go out 1461 # and search for a package with the pattern "^$basename" 1462 # - once found we'll take latest one assuming that this is highest 1463 # installed version 1464 1465 my ($rpathtime, $rpath) = (0, '');; 1466 DiveDir($StowDir, undef, sub { 1467 my $d = shift; 1468 my $t = (stat($d))[9]; 1469 #print "$d: ", scalar localtime $t, "\n"; 1470 ($rpath, $rpathtime) = ($d, $t) 1471 if ($t > $rpathtime); 1472 }, 1473 {Dive=>0, RegExpIncl=> ["^$basename"], Continue => 1}); 1474 1475 printV1("Retrieving configuration from basename \"$basename\".\n"); 1476 1477 if ($rpathtime > 0) { 1478 my $conf = GetPackageConfiguration($rpath); 1479 1480 if (!defined $conf || $conf eq '__NONE__') { 1481 print "$package: No configuration found (probably couldn't parse config.status, fixme!)!\n"; 1482 return undef; 1483 } 1484 1485 # take --prefix=... option out 1486 1487 $conf =~ s/\s--prefix=.+?\s/ /; 1488 $conf =~ s/^\s+//; 1489 1490 if ($Verbose) { 1491 print("Options taken from ", GetBaseName($rpath), ": ", 1492 $conf, "\n"); 1493 # give the user a chance to validate the configuration 1494 print "Sleeping..."; sleep(3); print "done.\n"; 1495 } 1496 1497 return $conf; 1498 } 1499 return undef; 1500} 1501 1502# Merge options, kill every option in addopts which is also in opts 1503# this doens't consider --enable/--disable nor --with/--without pairs 1504# XXX todo if pain raises 1505sub MergeOptions { 1506 my ($opts, $addopts) = @_; 1507 1508 $opts = '' unless defined $opts; 1509 $addopts = '' unless defined $addopts; 1510 1511 my @o = split /\s+/, $opts; 1512 my @ao = split /\s+/, $addopts; 1513 1514 foreach (@o) { 1515 if (/^'?(--?[-\d\w]+)/) { 1516 my $p = $1; 1517 for (my $i = 0; $i < scalar @ao;) { 1518 if ($ao[$i] =~ /^'?(--?[-\d\w]+)/ && 1519 $p eq $1) { 1520 splice(@ao, $i, 1); 1521 next; 1522 } 1523 $i++; 1524 } 1525 } 1526 } 1527 join(' ', @o, @ao); 1528} 1529 1530# we don't want to run ldconfig all the time, just at the end 1531# should be sufficient, so we just save the wish here and 1532# FinishLdconfig does the real call 1533sub RequestLdconfig { 1534 $CallLdconfig = 1; 1535} 1536 1537# call ldconfig if available and UID==0 1538sub FinishLdconfig { 1539 1540 # only run if running ldconfig was requested 1541 return 1 unless $CallLdconfig; 1542 1543 # return successful if $Dryrun 1544 return 1 if $DryRun; 1545 1546 # do nothing and return with success if not root... 1547 return 1 if $>; 1548 1549 # assumption: if the system has a ldconfig it's in /sbin 1550 return 1 unless -x $Progs{ldconfig}; 1551 1552 # call it 1553 printV1 "Calling ldconfig.\n"; 1554 system($Progs{ldconfig}); 1555 return 0 if $?; 1556 1557 return 1; 1558 1559} 1560 1561# - -- ------ - - - --- - - - - - - - - - - - - - - - - - - - 1562# the following subs are beginning with "Do" and are normally given 1563# the params from @ARGV 1564# they should return 1 on success and 0 otherwise 1565 1566sub DoMakeInst { 1567 my $path = shift; 1568 1569 $path = RelToAbsPath(getcwd(), UnTildePath($path)); 1570 if ($path !~ /\//) { 1571 printV1("Error with path!\n"); 1572 return 0; 1573 } 1574 my $package = GetPackageName($path); 1575 unless (defined $package) { 1576 printV1("Could not determine package name!\n"); 1577 return 0; 1578 } 1579 printV1("Package name: $package\n"); 1580 1581 # check if we're in the right dir 1582 unless ($DryRun || -r "$path/config.status") { 1583 printV1("no $path/config.status found!, aborting.\n"); 1584 return 0; 1585 } 1586 1587 my $ret = my $packageNotExisted = CheckPackageExistance($package); 1588 1589 my $m = GetParamsForMake($package); 1590 $m = ' '.$m if $m ne ''; 1591 $m = "prefix=\"$StowDir/$package$SubDirName\"".$m; 1592 printV1 "Installing package via \"$Progs{make} install $m\"\n" 1593 if $ret; 1594 $ret &&= CallOutput(("#"x75)."\n", 1595 "cd \"$path\"; $Progs{make} install $m", 1596 "Couldn't exec \"$Progs{make} install".$m."\"!", 1597 $MakeErrorScanPattern, 1598 ("#"x75)."\n"); 1599 1600 # create additional dirs to save configs 1601 printV1 "Copying config-file ..." if $ret && !$DryRun; 1602 $ret &&= CreateConfigDirInPackage($package); 1603 $ret &&= CreateCreatorInfoFile($package); 1604 $ret &&= CopyFile("$path/config.status", 1605 GetConfigDirForPackage($package)."/config.status"); 1606 printV1 "done.\n" if $ret && !$DryRun; 1607 1608 $ret &&= !(defined DoDepends($package)); 1609 $ret &&= !(defined DoStrip($package)); 1610 $ret &&= $BoolStrip || !(defined DoChecksums($package)); 1611 $ret = DoRemoveSource($path, $package) && $ret 1612 if ($RemoveSource && ($ret || $ActualCommand eq 'install')); 1613 1614 unless ($BoolNoInstallInfo) { 1615 # XXX RegisterInfoDocumentation(); 1616 } 1617 1618 # something failed --> remove broken package if was not forced 1619 DoRemove($package) 1620 if !$ret && $packageNotExisted && !$BoolForce && 1621 -e $StowDir."/".$package; 1622 1623 printLOG("$package: makeinst ", ($ret)?"successful.":"failed!", "\n"); 1624 $ret; 1625} 1626 1627sub DoRemoveSource { 1628 my $path = shift; 1629 my $package = shift; # only for needed for output 1630 return 0 unless (-d $path); 1631 my $p = GetBaseName($path); 1632 $package = $p unless (defined $package); 1633 my $cwd = getcwd(); 1634 chdir('..') if (!$DryRun && index($path.'/', "$cwd/") != -1); 1635 return 0 unless 1636 (CallSilent("Removing unpacked source of package $package ...", 1637 "$Progs{rm} rm -rf \"$path\"", 1638 1, "\n", "done.\n")); 1639 printLOG "$package: unpacked source removed\n"; 1640 1; 1641} 1642 1643sub DoUnTar { 1644 my $file = shift; 1645 my @extractfiles = @_; 1646 1647 $file = RelToAbsPath(getcwd(), $file); 1648 1649 if (! -r $file || -d $file) { 1650 printV1("File $file does not exist!\n"); 1651 return 0; 1652 } 1653 1654 # find out type of package 1655 my $decomp = GetTarfileDecompressor($file); 1656 return 0 unless defined $decomp; 1657 return 0 unless (MkDir($DumpDir)); 1658 1659 # tar out the file 1660 my $ret = CallExitCode 1661 ("Un-tar-ing file $file in $DumpDir ...", 1662 "cd \"$DumpDir\"; $decomp \"$file\" | $Progs{tar} xf - ". 1663 join(' ', @extractfiles), 1664 "Error while Un-tar-ing file $file!\n", 1665 "done.\n"); 1666 1667 printLOG("$file un-tar-", ($ret)?"ed successfully":"ing failed", ".\n"); 1668 return $ret if (!defined wantarray || !wantarray); 1669 1670 ($ret, $DumpDir.'/'.GetFirstDirFromTar($file, "$decomp")); 1671} 1672 1673sub DoConfHelp { 1674 my $p = RelToAbsPath(getcwd(), shift); 1675 1676 if (-d $p) { 1677 if (! -x "$p/configure") { 1678 printV1("There's no `configure' script in $p!"); 1679 return 0; 1680 } 1681 system("$p/configure", '--help'); 1682 return 1; 1683 } 1684 1685 # $p is a file 1686 my $d = GetFirstDirFromTar($p, GetTarfileDecompressor($p)); 1687 my ($ret, $tardir) = DoUnTar($p, "$d/configure"); 1688 return 0 unless $ret; 1689 1690 if (-x "$tardir/configure") { 1691 system("$tardir/configure", '--help'); 1692 } else { 1693 printV1("$p does not seem to contain a configure script!"); 1694 } 1695 1696 return DoRemoveSource($tardir, $tardir); 1697} 1698 1699sub DoMake { 1700 my $path = shift; 1701 1702 $path = RelToAbsPath(getcwd(), UnTildePath($path)); 1703 if ($path !~ /\//) { 1704 printV1("Error with path!\n"); 1705 return 0; 1706 } 1707 my $package = GetPackageName($path); 1708 unless (defined $package) { 1709 printV1("Could not determine package name!\n"); 1710 return 0; 1711 } 1712 1713 # check, if the package contains a "configure" script... 1714 if ($BoolConfigure && !$DryRun && !-x "$path/configure") { 1715 printV1("Package $package does not contain \"configure\" file!\n"); 1716 return 0; 1717 } 1718 1719 # this prints a warning if the package already exists... 1720 CheckPackageExistance($package); 1721 1722 # call "configure" now 1723 if ($BoolConfigure) { 1724 my $c = GetParamsForConfigure($package); 1725 $c = ' '.$c if $c ne ''; 1726 $c = "--prefix=\"$TargetDir$SubDirName\"".$c; 1727 if ($BoolUseSavedOptions) { 1728 $c = MergeOptions($c, GetSavedOptionsFromOlderPackage($package)); 1729 } 1730 return 0 unless 1731 CallOutput("Calling \"configure $c\" ...\n".('#'x75)."\n", 1732 "cd \"$path\"; ./configure $c", 1733 "Error while processing \"configure ".$c."\"\n", 1734 $ConfigureErrorScanPattern, 1735 ('#'x75)."\n"); 1736 printLOG("$package: 'configure' was successful.\n"); 1737 } 1738 1739 1740 my $m = GetParamsForMake($package); 1741 $m = ' '.$m if $m ne ''; 1742 my $j = GetParallelParamForMake(); 1743 $j = ' '.$j if $j ne ''; 1744 # call make now 1745 return 0 unless 1746 (!$BoolMake || 1747 CallOutput("Calling \"make".$j.$m."\" ...\n".('#'x75)."\n", 1748 "cd \"$path\"; $Progs{make}".$j.$m, 1749 "Error while running \"make".$m."\"!\n", 1750 $MakeErrorScanPattern, 1751 ('#'x75)."\n")); 1752 printLOG("$package: 'make' was successful.\n") if ($BoolMake); 1753 1754 if ($BoolMake && $BoolMakeCheck && 1755 IsRuleInMakefile('check', "$path/Makefile")) { 1756 return 0 unless 1757 (CallOutput("Calling \"make check".$m."\" ...\n".('#'x75)."\n", 1758 "cd \"$path\"; $Progs{make} check".$m, 1759 "Error while running \"make check".$m."\"!\n", 1760 $MakeErrorScanPattern, 1761 ('#'x75)."\n")); 1762 1763 printLOG("$package: 'make check' was successful\n"); 1764 } 1765 1766 1; 1767} 1768 1769sub DoInstPackage { 1770 my ($file) = @_; 1771 1772 $file = RelToAbsPath(getcwd(), $file); 1773 1774 if (! -r $file) { 1775 printV1("File $file does not seem to exist!\n"); 1776 return 0; 1777 } 1778 1779 my $package = my $dn = GetFirstDirFromTar($file, "$Progs{gzip} -cd"); 1780 $package = GetPackageName($package) if (defined $package); 1781 unless (defined $package) { 1782 printV1("Could not determine package name!\n"); 1783 return 0; 1784 } 1785 return 0 unless (CheckPackageExistance($package)); 1786 1787 return 0 1788 unless (CallSilent("Unpacking $file in $StowDir ...", 1789 "cd \"$StowDir\"; $Progs{gzip} -cd \"$file\" | tar xf -", 1790 1, "\nErrors while un-tar-ing package!\n", 1791 "done.\n")); 1792 1793 if ($dn ne $package) { 1794 return 0 unless DoRename($dn, $package); 1795 } 1796 1797 return 0 if (defined DoCheckIn($package)); 1798 1799 printLOG "$file successfully installed\n"; 1800 1; 1801} 1802 1803sub DoInstall { 1804 my $arg = UnTildePath(shift); 1805 1806 return 0 unless (-e $arg); 1807 my $p = $arg; 1808 unless ( -d $arg) { 1809 my @a = DoUnTar($arg); 1810 unless ($a[0]) { 1811 DoRemoveSource($a[1]) if $RemoveSource && $a[1]; 1812 return 0; 1813 } 1814 $p = $a[1]; 1815 } 1816 unless (DoMake($p) && DoMakeInst($p)) { 1817 DoRemoveSource(RelToAbsPath(getcwd(), $p)) if $RemoveSource; 1818 return 0; 1819 } 1820 unless ( -d $arg) { 1821 return 0 if (defined DoCheckIn($p)); 1822 } else { 1823 return 0 1824 if (defined DoCheckIn(GetPackageName(RelToAbsPath(getcwd(), $p)))); 1825 } 1826 1; 1827} 1828 1829sub DoRename { 1830 my $oldpackage = GetBaseName(shift); 1831 my $newpackage = shift; 1832 1833 unless (-d $StowDir."/".$oldpackage) { 1834 printV1("Package $oldpackage does not exist!\n"); 1835 return 0; 1836 } 1837 1838 if (-d $StowDir."/".$newpackage) { 1839 printV1("Package $newpackage does already exist!\n"); 1840 return 0; 1841 } 1842 1843 my $stowedin = 0; 1844 my $ostat = GetPackageStatus($oldpackage); 1845 if (!$BoolForce && $ostat == PACKAGE_BROKEN) { 1846 printV1("Package $oldpackage is broken, please correct.\n"); 1847 return 0; 1848 } 1849 if ($ostat != PACKAGE_CHECKEDOUT) { 1850 return 0 if (defined DoCheckOut($oldpackage)); 1851 $stowedin = 1; 1852 } 1853 return 0 unless 1854 (CallSilent("Renaming package from \"$oldpackage\" to \"$newpackage\" ...", 1855 "cd \"$StowDir\"; $Progs{mv} \"$oldpackage\" \"$newpackage\"", 1856 1, "\n")); 1857 if ( -d "$StowDir/$newpackage/$ConfigDirName/$oldpackage") { 1858 return 0 unless 1859 (CallSilent(undef, 1860 "cd \"$StowDir/$newpackage/$ConfigDirName\"; ". 1861 "$Progs{mv} \"$oldpackage\" \"$newpackage\"", 1862 1, "\n")); 1863 } 1864 my $confdirnew = GetConfigDirForPackage($newpackage); 1865 if ( -r "$confdirnew/$ChecksumFileName") { 1866 return 0 unless 1867 (ReplaceInFile("$confdirnew/$ChecksumFileName", 1868 " $ConfigDirName/$oldpackage", 1869 " $ConfigDirName/$newpackage")); 1870 } 1871 if ( -r "$confdirnew/$CreatorInfoFileName") { 1872 return 0 unless 1873 (ReplaceInFile("$confdirnew/$CreatorInfoFileName", 1874 "^Package.*$oldpackage", 1875 "Package : $newpackage")); 1876 } 1877 1878 printV1("done.\n"); 1879 1880 if ($stowedin) { 1881 return 0 if (defined DoCheckIn($newpackage)); 1882 } 1883 1884 printLOG "$oldpackage successfully renamed to $newpackage\n"; 1885 1; 1886} 1887 1888sub DoExchange { 1889 my ($from, $to) = @_; 1890 1891 ($from, $to) = (GetPackageName($from), GetPackageName($to)); 1892 1893 DoCheckOut($from); 1894 DoCheckIn($to); 1895 1896 printLOG "Package $to and $from exchanged.\n"; 1897 1; 1898} 1899 1900sub DoRebuild { 1901 return 0 unless (CheckDir($StowDir)); 1902 # memorize all packages which are checked in 1903 # broken packages will _not_ be checked in again 1904 printV1("Memorizing checked in/checked out situation ..."); 1905 my %rebuild_mem = (); 1906 DiveDir($StowDir, undef, sub { 1907 my $p = GetBaseName(shift); 1908 $rebuild_mem{$p} = 1909 ((GetPackageStatus($p))[0] == PACKAGE_CHECKEDIN); 1910 }, 1911 {Dive=>0, FollowLinks=>1, Continue=>1}); 1912 printV1("done.\nRemoving link farm ..."); 1913 sub __rebuild_rm { 1914 CallSilent(undef, "$Progs{rm} -rf \"$_[0]\""); 1915 undef; 1916 } 1917 DiveDir($TargetDir, \&__rebuild_rm, \&__rebuild_rm, 1918 {Dive=>0, CheckWithPath=>1, RealRegExp=>1, Continue=>1, 1919 RegExpExcl => ["^$StowDir\$"]}); 1920 printV1("done.\nChecking package(s) in again:\n"); 1921 foreach (keys %rebuild_mem) { 1922 print(" "), DoCheckIn($_) if ($rebuild_mem{$_}); 1923 } 1924 printV1("rebuild done.\n"); 1925 printLOG "rebuild done\n"; 1926 1; # we return 1 for success in this section of the source file 1927} 1928 1929sub DoConfig { 1930 # print the values of the following vars 1931 foreach ( sort @ConfigVarList ) { 1932 eval "PrintValues('$_', \\$_);"; 1933 print "\n"; 1934 print $@ if ($@ ne ''); 1935 } 1936 1; # success 1937} 1938 1939sub DoShell { 1940 printV1("Would start your shell.\n"), return(1) if $DryRun; 1941 # calling shell with all environment variables set 1942 my $sh = $ENV{SHELL}; 1943 if (defined $sh && -x $sh) { 1944 printV1 "Calling \"$sh\".\n"; 1945 system($sh); 1946 printV1 "stowES: shell done.\n"; 1947 } else { 1948 print "Could not start ", (defined $sh)?"\"".$sh."\"":"nothing"; 1949 } 1950 1; # success 1951} 1952 1953sub DoCheckTarget { 1954 return 0 unless (CheckDir($StowDir)); 1955 print "Checking targetdir $TargetDir: "; 1956 my @ctd = CheckTargetDir(); 1957 if ($#ctd == -1) { 1958 print "OK\n"; 1959 } else { 1960 print "\n"; 1961 my @ar_f = map{(s/^f:(.*)/$1/)?($_):()} @ctd; 1962 my @ar_o = map{(s/^o:(.*)/$1/)?($_):()} @ctd; 1963 print " Not a directory or link: ", join(', ', @ar_f), "\n" 1964 if ($#ar_f != -1); 1965 print " Wrong link(s): ", join(', ', @ar_o), "\n" 1966 if ($#ar_o != -1); 1967 } 1968 1; # success here 1969} 1970 1971# - -- ------ - - - --- - - - - - - - - - - - - - - - - - - - 1972# the following subs are beginning with "Do" and are normally used 1973# with DiveDir so that they should return "undef" if operation was 1974# successful... 1975 1976 1977my $__Command_CheckStow_AccSize; # global var accumulation package sizes 1978my $__Command_CheckStow_AccSize_I; # acc package sizes for installed packs 1979# this one is called from DoList and DoCheckStow because these 1980# commands do nearly the same... 1981sub __DoList_and_CheckStow { 1982 my $package = GetPackageName(shift); 1983 my $mode = shift; 1984 my $status; 1985 my @conflicts; 1986 my $size = ""; 1987 my $kbytes = 0; 1988 1989 if ($mode eq "check") { 1990 # GetPackageStatus takes a really long time 1991 ($status, undef, undef, @conflicts) = GetPackageStatus($package); 1992 # assumption: 2 blocks are 1 kbyte 1993 $kbytes = (GetPackageSize($package))[1]/2; 1994 $__Command_CheckStow_AccSize += $kbytes; 1995 $size = sprintf("(%7s) ", getDottedFigure($kbytes)); 1996 } else { # mode is "list" 1997 # IsStowedIn is faster than GetPackageStatus but will not check 1998 # for broken packages... 1999 $status = (IsStowedIn_simple($package))?PACKAGE_CHECKEDIN:PACKAGE_CHECKEDOUT; 2000 } 2001 2002 if ($status == PACKAGE_CHECKEDIN) { 2003 print "I $size$package\n"; 2004 $__Command_CheckStow_AccSize_I += $kbytes; 2005 } elsif ($status == PACKAGE_BROKEN) { 2006 my $l = length($TargetDir)+1; 2007 print("X $size$package (", 2008 join(', ', map {substr($_, $l)} @conflicts), ")\n"); 2009 } else { 2010 my $res = CanPackageBeStowedIn($package); 2011 if ($res eq '') { 2012 print "s $size$package\n"; 2013 } else { 2014 my $l = readlink($res); 2015 if (defined $l) { 2016 my $t = $res; 2017 $res = $l if (defined $l); 2018 $res = RelToAbsPath(GetPathName($t), $res); 2019 } 2020 print "- $size$package (", substr($res, length($TargetDir)+1), ")\n"; 2021 } 2022 } 2023 undef; 2024} 2025 2026sub DoCheckStow { __DoList_and_CheckStow(shift, "check"); } 2027sub DoList { __DoList_and_CheckStow(shift, "list"); } 2028 2029sub DoChecksums { 2030 return undef unless ($BoolChecksums); 2031 my $package = GetPackageName(shift); 2032 return 0 unless (CheckDir($StowDir."/".$package)); 2033 2034 unless (CheckDir(GetConfigDirForPackage($package), 1)) { 2035 return 0 unless (CreateConfigDirInPackage($package)); 2036 } 2037 2038 if ($DryRun) { 2039 print "Would create checksums for package $package.\n"; 2040 return undef; 2041 } 2042 2043 printV1 "Creating MD5sums for package $package ..."; 2044 unless (open(MD5FILE, 2045 ">".GetConfigDirForPackage($package)."/$ChecksumFileName")) { 2046 printV1("Error creating file $ChecksumFileName!\n"); 2047 return 0; 2048 } 2049 DiveDir($StowDir."/".$package, 2050 sub { 2051 my $output = `$Progs{md5sum} "$_[0]"`; 2052 my $s = "$StowDir/$package"; 2053 my $i = index($output, $s); 2054 $output = 2055 substr($output, 0, $i).substr($output, $i + length($s) + 1) 2056 if ($i != -1); 2057 print MD5FILE $output; 2058 }, 2059 undef, 2060 {Dive=>1, CheckWithPath=>1, RealRegExp=>0, Continue=>1, 2061 RegExpExcl => 2062 [GetConfigDirForPackage($package)."/$ChecksumFileName"]}); 2063 2064 close MD5FILE; 2065 printV1 "done.\n"; 2066 printLOG "$package: created checksums successfully\n"; 2067 undef; 2068} 2069 2070sub DoDepends { 2071 return undef unless ($BoolDepends); 2072 my $package = GetPackageName(shift); 2073 return 0 unless (CheckDir($StowDir."/".$package)); 2074 2075 unless (CheckDir(GetConfigDirForPackage($package))) { 2076 return 0 unless (CreateConfigDirInPackage($package)); 2077 } 2078 2079 if ($DryRun) { 2080 print "Would create dependencies for package $package.\n"; 2081 return undef; 2082 } 2083 2084 printV1 "Creating dependencies for package $package ..."; 2085 my @dep_data = (); 2086 DiveDir($StowDir."/".$package, 2087 sub { 2088 my ($file) = @_; 2089 2090 return unless (-x $file); # only checking executables here... 2091 # it's important that $file has a slash somewhere... 2092 # see ldd(1) 2093 my $text = `$Progs{ldd} "$file" 2>&1`; 2094 return 2095 if ($text =~ /^ldd: /); # ldd: $file is not a.out or ELF 2096 foreach my $line (split(/\n/, $text)) { 2097 push @dep_data, $1 if $line =~ /\s(\S+)\s+=>\s/; 2098 } 2099 }, 2100 undef, 2101 {Dive=>1, Continue=>1}); 2102 @dep_data = ExcludeLibs( Uniq (sort @dep_data)); 2103 2104 unless (open(DEPFILE, 2105 ">".GetConfigDirForPackage($package)."/$DependencyFileName")) { 2106 printV1("Error creating file $DependencyFileName!\n"); 2107 return 0; 2108 } 2109 print DEPFILE join("\n", @dep_data); 2110 close DEPFILE; 2111 printV1 "done.\n"; 2112 printLOG "$package: created dependencies successfully\n"; 2113 undef; 2114} 2115 2116sub DoCheckIn { 2117 return undef unless ($BoolCheckIn); 2118 my $package = GetPackageName(shift); 2119 return 0 unless (CheckDir($StowDir."/".$package)); 2120 my $stat = GetPackageStatus($package); 2121 if ($stat == PACKAGE_BROKEN) { 2122 printV1("Package $package is broken, please correct.\n"); 2123 return 0; 2124 } 2125 if (GetPackageStatus($package) == PACKAGE_CHECKEDIN) { 2126 printV2 "No need to check in since package \"$package\" is checked in!\n"; 2127 return undef; 2128 } elsif ($DryRun) { 2129 printV1 2130 "Would check in package $package (it's not checked in currently).\n"; 2131 return undef; 2132 } 2133 my $res = CanPackageBeStowedIn($package); 2134 if ($res ne '') { 2135 printV1("Package cannot be checked in, conflict: $res\n"); 2136 return 0; 2137 } 2138 2139 return 0 unless 2140 CallSilent("Calling \"stow\" to check in package $package ...", 2141 "$Progs{stow} --target=\"$TargetDir\" " 2142 ."--dir=\"$StowDir\" \"$package\"", 2143 1, "\nAn error occured while processing stow:\n", 2144 "done.\n"); 2145 # assumption: libs are in a lib directory 2146 RequestLdconfig() if -d "$StowDir/$package/lib"; 2147 printLOG "$package: checked in\n"; 2148 undef; 2149} 2150 2151sub DoCheckOut { 2152 my $package = GetPackageName(shift); 2153 return 0 unless (CheckDir($StowDir."/".$package)); 2154 if (GetPackageStatus($package) == PACKAGE_CHECKEDOUT) { 2155 printV2 "No need to check out since package $package is not checked in!\n"; 2156 return undef; 2157 } elsif ($DryRun) { 2158 printV1 "Would check out package $package (it's checked in currently)\n"; 2159 return undef; 2160 } 2161 2162 return 0 unless 2163 CallSilent("Calling \"stow -D\" to check out package $package ...", 2164 "$Progs{stow} --target=\"$TargetDir\" " 2165 ."--dir=\"$StowDir\" -D \"$package\"", 2166 1, "\nAn error occured while processing stow:\n", 2167 "done.\n"); 2168 RequestLdconfig() if -d "$StowDir/$package/lib"; 2169 printLOG "$package: checked out\n"; 2170 2171 # print a warning if the checked out package contains suid binaries, 2172 # in case the new package was a security fix it may be wise to un-suid 2173 # to old binary/-ies... 2174 my $suid_used = 0; 2175 DiveDir("$StowDir/$package", 2176 sub { 2177 my $file = shift; 2178 $suid_used ||= (stat($file))[2] & 06000; # suid or guid set 2179 return $suid_used if $suid_used; 2180 undef; 2181 }, 2182 undef, 2183 {Dive => 1}); 2184 print "WARNING: Package \"$package\" contains suid binaries, take care!\n" 2185 if $suid_used; 2186 undef; 2187} 2188 2189sub DoRemove { 2190 my $package = GetPackageName(shift); 2191 return 0 unless (CheckDir($StowDir."/".$package)); 2192 return 0 if (defined DoCheckOut($package)); 2193 2194 return 0 unless 2195 CallSilent("Calling \"rm -rf\" to remove package $package ...", 2196 "cd \"$StowDir\"; $Progs{rm} -rf \"$package\"", 2197 1, "\nAn error occured while removing package:\n", 2198 "done.\n"); 2199 printLOG "$package: removed\n"; 2200 undef; 2201} 2202 2203sub DoPackage { 2204 my $package = GetPackageName(shift); 2205 return 0 unless (CheckDir("$StowDir/$package")); 2206 return 0 unless (MkDir($DumpDir)); 2207 2208 my $packname = "$DumpDir/$package.stowES". 2209 ((defined $PackageSuffix)?".$PackageSuffix":'').".tar.gz"; 2210 2211 return 0 2212 unless (CallSilent("Creating a package of $package in $DumpDir ...", 2213 "(cd \"$StowDir\"; $Progs{tar} cf - \"$package\") " 2214 ."| $Progs{gzip} > \"$packname\"", 2215 1, "\nError while creating package:\n", 2216 "done.\n")); 2217 printLOG "$package: packaged\n"; 2218 undef; 2219} 2220 2221sub DoContentSearch { 2222 my $package = GetPackageName(shift); 2223 2224 if ($DryRun) { 2225 print "Would search in package $package.\n"; 2226 return undef; 2227 } 2228 2229 print "Package $package:\n"; 2230 DiveDir($StowDir."/".$package, 2231 sub { 2232 my $file = shift; 2233 2234 unless (open F, $file) { 2235 print "Could not open file $file!\n"; 2236 return; 2237 } 2238 my $matches = 0; 2239 while (defined ($_ = <F>)) { 2240 while (/$ContentSearchPattern/g) { $matches++ }; 2241 } 2242 close F; 2243 if ($matches) { 2244 print "$matches match", ($matches>1)?"es":"", " in $file\n"; 2245 print CSF $file, "\n"; 2246 } 2247 }, 2248 undef, 2249 {Dive=>1, CheckWithPath=>1, RealRegExp=>0, Continue=>1, 2250 RegExpExcl=> 2251 [GetConfigDirForPackage($package)."/$ChecksumFileName"]}); 2252 printLOG "$package: content search done\n"; 2253 undef; 2254} 2255 2256sub DoCheckChecksums { 2257 return undef unless ($BoolCheckChecksums); 2258 my $package = GetPackageName(shift); 2259 2260 2261 # this will only check files listed in $ChecksumFileName 2262 # ----- Security-hole? ----- 2263 CallSilent("Checking checksums for package $package ...", 2264 "cd \"$StowDir/$package\"; $Progs{md5sum} -c " 2265 ."\"$ConfigDirName/$package/$ChecksumFileName\"", 2266 1, "\n", 2267 " ok.\n"); 2268 printLOG "$package: checked checksums\n"; 2269 undef; 2270} 2271 2272sub DoStrip { 2273 return undef unless ($BoolStrip); 2274 my $package = GetPackageName(shift); 2275 2276 if ($DryRun) { 2277 print "Would strip files in package $package.\n"; 2278 return undef; 2279 } 2280 2281 printV1 "Stripping files for package $package ..."; 2282 DiveDir($StowDir.'/'.$package, 2283 sub { 2284 my $file = shift; 2285 CallSilent(undef, "$Progs{strip} \"$file\"", 0, undef, undef); 2286 }, 2287 undef, 2288 {Dive=>1, Continue=>1}); 2289 printV1 "done.\n"; 2290 printLOG "$package: stripped\n"; 2291 2292 # redo checksum 2293 return 1 if (defined DoChecksums($package)); 2294 undef; 2295} 2296 2297sub DoContents { 2298 my $package = GetPackageName(shift); 2299 if ($DryRun) { 2300 print "Would display contents of package $package.\n"; 2301 return undef; 2302 } 2303 2304 sub __l { 2305 my $file = shift; 2306 my $type = undef; 2307 $type = 'd' if -d $file; 2308 $type = 'l' if -l $file; 2309 $type = 'p' if -p $file; 2310 $type = 's' if -S $file; 2311 $type = 'b' if -b $file; 2312 $type = 'c' if -c $file; 2313 if (defined $type) { 2314 print "$type $file\n"; 2315 } else { 2316 print "f $file (", (stat($file))[7], ")\n"; 2317 } 2318 } 2319 2320 print "Contents of package $package:\n"; 2321 DiveDir($StowDir.'/'.$package, \&__l, \&__l, 2322 {Dive=>1, Continue=>1, FollowLinks=>1}); 2323 2324 printLOG "$package: displayed contents"; 2325 undef; 2326} 2327 2328sub DoCheckLibs { 2329 my $package = GetPackageName(shift); 2330 return 0 unless (CheckDir($StowDir.'/'.$package)); 2331 2332 if ($DryRun) { 2333 print "Checking libs for package $package.\n"; 2334 return undef; 2335 } 2336 2337 print "Package $package:\n"; 2338 my $ff = undef; 2339 DiveDir($StowDir."/".$package, 2340 sub { 2341 my $file = shift; 2342 return unless (-x $file && !defined $ff); 2343 my $text = `$Progs{ldd} "$file" 2>&1`; 2344 return if ($text =~ /^ldd: /); # no valid file 2345 $ff = $file 2346 if ($text =~ /(not found\)?|No such file or directory)$/m); 2347 }, 2348 undef, 2349 {Dive=>1, CheckWithPath=>1, RealRegExp=>0, Continue=>1, 2350 RegExpExcl => [GetConfigDirForPackage($package)]}); 2351 2352 print "Unmet dependency: $ff\n" if (defined $ff); 2353 printLOG "$package: checked libraries\n"; 2354 undef; 2355} 2356 2357sub DoShowConfig { 2358 my $package = GetPackageName(shift); 2359 return 0 unless (CheckDir($StowDir.'/'.$package)); 2360 2361 if ($DryRun) { 2362 print "Showing saved configuration for package $package.\n"; 2363 return undef; 2364 } 2365 2366 my $f = GetConfigDirForPackage($package).'/config.status'; 2367 unless (-r $f) { 2368 print "No saved configuration for $package.\n"; 2369 return undef; 2370 } 2371 2372 2373 my $ret = GetPackageConfiguration($package); 2374 2375 if (!defined $ret) { 2376 print STDERR "Could not open $f!"; 2377 return undef; 2378 } 2379 2380 if ($ret ne '__NONE__') { 2381 print "Configuration for $package: $ret\n"; 2382 printLOG "$package: showed configuration\n"; 2383 } else { 2384 print "$package: No configuration found (probably couldn't parse config.status, fixme!)!\n"; 2385 printLOG "$package: no configuration found\n"; 2386 } 2387 2388 undef; 2389} 2390 2391# -- - - - -- - -- --- - - - - - - -- - - - - - -- - - - - - 2392 2393sub CallCommands { 2394 my $return_code = 1; 2395 for my $Command (@Command) { 2396 $ActualCommand = $Command; # using $ActualCommand directly does not work 2397 $return_code = eval("Command_$Command();") && $return_code; 2398 if ($@ ne '' && !$return_code && !$Continue) { 2399 print "Error code from eval: $@"; 2400 return 3; 2401 } 2402 } 2403 $return_code; 2404} 2405 2406 2407# this is a sub used for Command_{checksums,depends,checkout,checkin} 2408# because these subs do nearly the same... 2409# they take packages as arguments 2410sub DoForPackagePack { 2411 my ($ambig, $func) = @_; 2412 if ($#ARGV == -1 && !$ProceedAllPackages) 2413 { ShortUsage(); return 1; } 2414 return 1 unless (CheckDir($StowDir)); 2415 if (defined $PackageName) { 2416 printV1("Option -p not possible here!\n"); 2417 return 1; 2418 } 2419 my $matches; 2420 if ($ambig) { 2421 $matches = CountMatchesInDir($StowDir, @ARGV); 2422 $matches || (printV1("No matches to your query.\n"), return 1); 2423 } 2424 for my $arg (@ARGV) { 2425 unless ($ambig) { # check that every regexp matches exactly once 2426 $matches = CountMatchesInDir($StowDir, $arg); 2427 $matches || (printV1("No matches to your query \"$arg\".\n"), return 1); 2428 } 2429 if (!$ambig && (!$Ambiguous && !$ProceedAllPackages && $matches > 1)) { 2430 if ($Verbose) { 2431 print "Found $matches matches for \"$arg\". ". 2432 "You may consider using option -m.\n"; 2433 DoForCheck_List(\&DoList, "list", $arg); 2434 } 2435 return 1; 2436 } 2437 } 2438 return 1 if defined DiveDir($StowDir, undef, $func, 2439 {Dive=>0, RegExpIncl=>\@ARGV, 2440 Continue => $Continue, FollowLinks=>1}); 2441 0; 2442} 2443 2444# this sub is used for commands taking files/dirs (makeinst, make, untar) 2445sub DoForPackageFile { 2446 my $func = shift; 2447 if ($#ARGV == -1) { ShortUsage(); return 1; } 2448 if (defined $PackageName && $#ARGV) { 2449 print "Option -p not possible when giving more than one argument!\n"; 2450 return 1; 2451 } 2452 unless (CheckDir($StowDir)) { 2453 printV1("Creating directory $StowDir\n"); 2454 return 1 unless (MkDir($StowDir)); 2455 } 2456 2457 if ($BoolRotateInstall && $ActualCommand eq 'install') { 2458 DoForPackageFileRotate($func); 2459 } else { 2460 DoForPackageFileNormal($func); 2461 } 2462} 2463 2464# build packages in the normal way 2465sub DoForPackageFileNormal { 2466 my $func = shift; 2467 2468 my $code = 1; 2469 for (@ARGV) { 2470 my $e = &{$func}($_); 2471 return 1 unless ($Continue || $e); 2472 $code = $code && $e; 2473 } 2474 !$code; 2475} 2476 2477# the "build around the clock up to everything fails"-feature 2478sub DoForPackageFileRotate { 2479 my $func = shift; 2480 my @done; 2481 @done = map {0} @done[0..$#ARGV]; 2482 my @old_done; 2483 my $goon; 2484 2485 do { 2486 @old_done = @done; 2487 $goon = 0; 2488 for (my $i=0; $i <= $#ARGV; $i++) { 2489 $done[$i] = $done[$i] || &{$func}($ARGV[$i]); 2490 $goon ||= $old_done[$i] != $done[$i]; 2491 } 2492 } while ($goon); 2493 for (my $i=0; $i <= $#ARGV; $i++) { 2494 return 1 unless $done[$i]; 2495 } 2496 0; # success 2497} 2498 2499sub DoForCheck_List { 2500 my ($func, $cmd, @reglist) = @_; 2501 my $c; 2502 return 0 unless (CheckDir($StowDir)); 2503 print((($cmd eq 'list')?'List':'Check'), "ing packages in $StowDir"); 2504 @reglist = @ARGV if scalar @reglist == 0; 2505 if ($#reglist >= 0) { 2506 print " matching "; 2507 PrintValues(undef, \@reglist); 2508 $c = CountMatchesInDir($StowDir, @reglist); 2509 } else { 2510 $c = CountMatchesInDir($StowDir); 2511 } 2512 print " ($c match", ($c != 1) ? "es" : "", "):\n"; 2513 $__Command_CheckStow_AccSize = undef; 2514 $__Command_CheckStow_AccSize_I = 0; 2515 DiveDir($StowDir, undef, $func, 2516 {Dive => 0, RegExpIncl => \@reglist, FollowLinks => 1}); 2517 print "Sum: ", getDottedFigure($__Command_CheckStow_AccSize), " kB ". 2518 " Inst: ", getDottedFigure($__Command_CheckStow_AccSize_I)," kB\n" 2519 if $__Command_CheckStow_AccSize; 2520 0; 2521} 2522 2523# ----------------------------------- 2524# these functions (only these!) 2525# return 0 on success and a number > 0 on failure (--> exit-code) 2526 2527sub Command_help { Usage(); 0; } 2528 2529sub Command_shell { !DoShell(); } 2530 2531sub Command_list { DoForCheck_List(\&DoList, "list"); } 2532sub Command_checkstow { DoForCheck_List(\&DoCheckStow, "check"); } 2533 2534sub Command_checktarget { !DoCheckTarget(); } 2535 2536sub Command_config { !DoConfig(); } 2537sub Command_rebuild { !DoRebuild(); } 2538 2539sub Command_makeinst { DoForPackageFile(\&DoMakeInst); } 2540sub Command_make { DoForPackageFile(\&DoMake); } 2541sub Command_untar { DoForPackageFile(\&DoUnTar); } 2542sub Command_instpack { DoForPackageFile(\&DoInstPackage); } 2543sub Command_install { DoForPackageFile(\&DoInstall); } 2544sub Command_confhelp { DoForPackageFile(\&DoConfHelp); } 2545 2546sub Command_checksums { DoForPackagePack(0, \&DoChecksums); } 2547sub Command_chkchksums { DoForPackagePack(1, \&DoCheckChecksums); } 2548sub Command_depends { DoForPackagePack(0, \&DoDepends); } 2549sub Command_checkin { DoForPackagePack(0, \&DoCheckIn); } 2550sub Command_checkout { DoForPackagePack(0, \&DoCheckOut); } 2551sub Command_package { DoForPackagePack(1, \&DoPackage); } 2552sub Command_strip { DoForPackagePack(0, \&DoStrip); } 2553sub Command_contents { DoForPackagePack(1, \&DoContents); } 2554sub Command_checklibs { DoForPackagePack(1, \&DoCheckLibs); } 2555sub Command_showconfig { DoForPackagePack(1, \&DoShowConfig); } 2556sub Command_remove { 2557 $ProceedAllPackages && (printV1("I won't make it that easy :-)\n"),return 1); 2558 DoForPackagePack(0, \&DoRemove); 2559} 2560 2561sub Command_contsearch { 2562 # open file to store found filenames 2563 unless ($DryRun || (open CSF, ">$ContentSearchFile")) { 2564 printV1("Could not open $ContentSearchFile!\n"); 2565 return 1; 2566 } 2567 my $res = DoForPackagePack(1, \&DoContentSearch); 2568 close CSF unless $DryRun; 2569 $res; 2570} 2571 2572sub Command_rename { 2573 ShortUsage(),return(1) if $#ARGV < 1; 2574 if (defined $PackageName) { 2575 printV1("Option \"p\" not allowed here!\n"); 2576 return 1; 2577 } 2578 while ($#ARGV > 0) { 2579 my @m = GetMatchesInDir($StowDir, $ARGV[0]); 2580 if ($#m == 0) { 2581 return 1 unless (DoRename($m[0], $ARGV[1])); 2582 } else { 2583 print "Regexp \"$ARGV[0]\" does not match exactly one package!\n"; 2584 return 1; 2585 } 2586 splice(@ARGV, 0, 2); 2587 } 2588 0; 2589} 2590 2591sub Command_exchange { 2592 ShortUsage(),return(1) if $#ARGV < 1; 2593 2594 if (defined $PackageName) { 2595 printV1("Option \"p\" not allowed here!"); 2596 return 1; 2597 } 2598 my ($from, $to) = (undef, undef); 2599 for (my $i = 0; $i < @ARGV; $i++) { 2600 my @m = GetMatchesInDir($StowDir, $ARGV[$i]); 2601 if (@m == 0) { 2602 print "No matches for \"$ARGV[$i]\"\n"; 2603 return 1; 2604 } elsif (@m > 1) { 2605 print "Regexp \"$ARGV[$i]\" does not match exactly one package!\n"; 2606 return 1; 2607 } else { 2608 if (!defined $from) { 2609 $from = $m[0]; 2610 } else { 2611 $to = $m[0]; 2612 last; 2613 } 2614 } 2615 } 2616 if (defined $from && defined $to) { 2617 return 1 unless DoExchange($from, $to); 2618 } else { 2619 2620 } 2621 0; 2622} 2623 2624sub Command_version { 2625 print $VersionString, " - version ", $Version, "\n"; 2626 0; 2627} 2628 2629# ----------------------------------- 2630 2631# Init 2632GetParams(); 2633Init(); 2634CheckForExternalPrograms() 2635 unless(grep /^help$|^config$|^version$|^shell$/, @Command); 2636 2637# call command 2638my $res = CallCommands(); 2639 2640# Done 2641EndWork(); 2642exit($res); 2643 2644 2645 2646