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