minor additions

5 files changed, 821 insertions, 0 deletions

diff --git a/ldapcat-1.2.pl b/ldapcat-1.2.pl
new file mode 100755
index 0000000..7740eab
--- /dev/null
+++ b/ldapcat-1.2.pl
@@ -0,0 +1,184 @@
+#!/usr/bin/perl -w
+##############################################################################
+# $Id: ldapcat,v 1.2 2002/02/22 00:41:31 jheiss Exp $
+##############################################################################
+# Search LDAP for users or groups and print them out in standard UNIX
+# format.
+#
+# TODO:
+# - Allow user to specify options to ldapsearch, like -x
+##############################################################################
+# $Log: ldapcat,v $
+# Revision 1.2  2002/02/22 00:41:31  jheiss
+# Made Base64 decoding optional.
+# Don't print out full entry for KERBEROS type passwords, just a marker.
+#
+# Revision 1.1  2002/02/09 03:24:50  jheiss
+# Initial revision
+#
+##############################################################################
+
+# Includes and such
+use strict;
+
+# Constants
+# Set the following to true to have any Base64 encoded fields decoded.
+# Requires that you have the MIME::Base64 module from CPAN.
+my $DECODE_BASE64 = 1;    # 1 for yes, 0 for no
+
+sub usage
+{
+    die "Usage: $0 {passwd|group}\n";
+}
+
+if (scalar @ARGV == 0)
+{
+    usage();
+}
+
+my %entries;
+my $entry;
+my @elements;
+
+if ($ARGV[0] eq 'passwd')
+{
+    open(LS,
+             "ldapsearch -LLL '(objectClass=posixAccount)' uid userPassword "
+           . "uidNumber gidNumber cn homeDirectory loginShell |"
+        )
+      || die "Failed to run ldapsearch";
+
+    #open(LS, "ldapsearch -x -LLL '(objectClass=posixAccount)' uid " .
+    #"userPassword uidNumber gidNumber cn homeDirectory loginShell |") ||
+    #die "Failed to run ldapsearch";
+} elsif ($ARGV[0] eq 'group')
+{
+    open(LS,
+             "ldapsearch -LLL '(objectClass=posixGroup)' cn userPassword "
+           . "gidNumber memberUid |"
+        )
+      || die "Failed to run ldapsearch";
+
+    #open(LS, "ldapsearch -x -LLL '(objectClass=posixGroup)' cn userPassword " .
+    #"gidNumber memberUid |") ||
+    #die "Failed to run ldapsearch";
+} else
+{
+    usage();
+}
+
+while (<LS>)
+{
+    #print "line:  '$_'\n";
+
+    if (/^dn: /)
+    {
+        if ($ARGV[0] eq 'passwd')
+        {
+            /dn: uid=(\w+),/;
+            $entry = $1;
+        } elsif ($ARGV[0] eq 'group')
+        {
+            /dn: cn=(\w+),/;
+            $entry = $1;
+        }
+
+        if (!$entry)
+        {
+            $entry = 'bogus';
+        }
+    } else
+    {
+        chomp;
+
+        /^(\w+):/;
+        if ($1)
+        {
+            my $field = $1;
+
+            #print "Field line:  $_\n";
+            #print "Field:  $field\n";
+
+            # Take off the field label
+            $_ =~ s/^[[:alpha:]]+://;
+
+            #print "Stripped:  '$_'\n";
+
+            # Check to see if the entry was encoded
+            if (/^: /)
+            {
+                #print "Encoded field $field\n";
+                $_ =~ s/^: //;
+                if ($DECODE_BASE64)
+                {
+                    require MIME::Base64;
+                    $_ = MIME::Base64::decode_base64($_);
+                }
+            } else
+            {
+                $_ =~ s/^ //;
+            }
+
+            # The userPassword field looks like:  {type}password
+            if ($field eq 'userPassword')
+            {
+                /^{(\w+)}(.*)/;
+                my $passtype = $1;
+                my $password = $2;
+
+                #print "passtype:  $1\n";
+                #print "password:  $2\n";
+
+                if ($passtype eq 'crypt')
+                {
+                    $_ = $2;
+                } elsif ($passtype eq 'KERBEROS')
+                {
+                    $_ = '*K*';
+                } else
+                {
+                    # Let other types pass through since I don't know what
+                    # else is possible
+                }
+            }
+
+            # There can be multiple members in a group
+            if ($field eq 'memberUid')
+            {
+                push(@{$entries{$entry}->{$field}}, $_);
+            } else
+            {
+                $entries{$entry}->{$field} = $_;
+            }
+        }
+    }
+}
+close(LS);
+
+if ($ARGV[0] eq 'passwd')
+{
+    foreach my $user (sort keys %entries)
+    {
+        print "$user:";
+        print $entries{$user}->{'userPassword'} . ":";
+
+        #print "x:";  # Fake password
+        print $entries{$user}->{'uidNumber'} . ":";
+        print $entries{$user}->{'gidNumber'} . ":";
+        print $entries{$user}->{'cn'} . ":";
+        print $entries{$user}->{'homeDirectory'} . ":";
+        print $entries{$user}->{'loginShell'} . "\n";
+    }
+} elsif ($ARGV[0] eq 'group')
+{
+    foreach my $group (sort keys %entries)
+    {
+        print "$group:";
+        print $entries{$group}->{'userPassword'} . ":";
+
+        #print "*:";  # Fake password
+        print $entries{$group}->{'gidNumber'} . ":";
+        print join(',', @{$entries{$group}->{'memberUid'}}) . "\n";
+    }
+}
+
diff --git a/rpm-verify-dnf.sh b/rpm-verify-dnf.sh
new file mode 100755
index 0000000..796a1e1
--- /dev/null
+++ b/rpm-verify-dnf.sh
@@ -0,0 +1,98 @@
+#!/bin/bash
+
+# Partial script version of http://fedorasolved.org/Members/fenris02/post_upgrade_cleanup
+# Mirrored on https://fedoraproject.org/wiki/User:Fenris02/Distribution_upgrades_and_cleaning_up_after_them
+# Trimmed to remove any features DNF lacks.
+
+LANG=C
+if [ "$(/usr/bin/whoami)" != "root" ]; then
+  echo "Must be run as root."
+  exit 1
+fi
+
+DS=$(/bin/date +%Y%m%d)
+TMPDIR=$(/bin/mktemp -d ${TMPDIR:-/tmp}/${0##*/}-XXXXX.log)
+[ -d "${TMPDIR}" ] || mkdir -p "${TMPDIR}"
+
+if [ -f /etc/sysconfig/prelink ]; then
+  echo "Updating prelink info ..."
+  . /etc/sysconfig/prelink \
+  time /usr/sbin/prelink -av $PRELINK_OPTS >> /var/log/prelink/prelink.log 2>&1
+fi
+
+/sbin/ldconfig
+
+# Remove temporary files
+/bin/rm /var/lib/rpm/__db.00?
+
+echo "rpm-Va: This may take 12mins or longer, please wait ... (Might be a good time for coffee)"
+time /bin/rpm -Va > ${TMPDIR}/rpm-va2_${DS}.txt 2>&1
+# Filter out prelink messages, kmod files, and kernel-devel files:
+/bin/egrep -v '^(prelink: /|S\..\.\.\.\.\.\.    /|.{9}    /lib/modules/.*/modules\.|.{9}    /usr/src/kernels/)' \
+  ${TMPDIR}/rpm-va2_${DS}.txt > ${TMPDIR}/RPM-VA2_${DS}.txt
+
+echo "Generating reports ..."
+/bin/egrep -v '^.{9}  c /' ${TMPDIR}/RPM-VA2_${DS}.txt > ${TMPDIR}/URGENT-REVIEW_${DS}.txt
+/bin/egrep '^.{9}  c /' ${TMPDIR}/RPM-VA2_${DS}.txt > ${TMPDIR}/REVIEW-CONFIGS_${DS}.txt
+/bin/find /etc -name '*.rpm?*' > ${TMPDIR}/REVIEW-OBSOLETE-CONFIGS_${DS}.txt
+
+echo "Requesting extra reporting tools to be installed ..."
+dnf install fpaste rpmdevtools policycoreutils-python
+
+if [ -x /usr/sbin/semanage ]; then
+  echo "Reporting SELinux policy ..."
+  TMPF=$(/bin/mktemp -u /tmp/${0##*/}-XXXXX.txt)
+  /usr/sbin/semanage -o $TMPF
+  /bin/mv $TMPF ${TMPDIR}/SELINUX-CUSTOM-CONFIG_${DS}.txt
+fi
+
+if [ -x /usr/bin/rpmdev-rmdevelrpms ]; then
+  echo "Reporting devel packages"
+  /usr/bin/rpmdev-rmdevelrpms -l > ${TMPDIR}/SHOW-DEVELRPMS_${DS}.txt
+fi
+
+echo "Reporting Problem RPMs"
+/bin/rpm -Va --nofiles --noscripts > ${TMPDIR}/PROBLEM-PACKAGES_${DS}.txt
+
+echo "Collect list of enabled repos"
+/usr/bin/dnf repolist > ${TMPDIR}/YUM-REPOLIST_${DS}.txt
+
+echo "Collecting distribution-synchronization differences"
+echo n |\
+  /usr/bin/dnf distro-sync |\
+  /bin/sed -e '1,/Dependencies Resolved/d;' > ${TMPDIR}/YUM-DISTROSYNC_${DS}.txt
+
+/bin/cat - <<EOT
+==========
+TMPDIR = ${TMPDIR}
+==========
+##### The following all break fpaste, so concatenate below instead:
+#/usr/bin/fpaste ${TMPDIR}/[A-Z]*_${DS}.txt
+## (excluding ${TMPDIR}/RPM-VA2_${DS}.txt to avoid duplicate info)
+#/usr/bin/fpaste ${TMPDIR}/{REVIEW,SHOW,URGENT}*_${DS}.txt
+==========
+EOT
+
+for fp in ${TMPDIR}/{YUM-REPOLIST,YUM-DISTROSYNC,URGENT-REVIEW,REVIEW-CONFIGS,PROBLEM-PACKAGES,DUPLICATE-PACKAGES,ORPHANED-PACKAGES,REVIEW-OBSOLETE-CONFIGS,SELINUX-CUSTOM-CONFIG,SHOW-DEVELRPMS,SHOW-EXTERNAL,SHOW-LEAVES,SHOW-INSTALLED2}*_${DS}.txt; do
+  if [ -s $fp ]; then
+    /bin/cat - >> ${TMPDIR}/fpaste-output_${DS}.txt <<EOT
+===============================================================================
+===== $fp
+===============================================================================
+EOT
+    ### Limit each output file to 1000 lines to prevent excessive flooding.
+    WCL=$(/usr/bin/wc -l $fp |/usr/bin/gawk '{print$1}')
+    if [ $WCL -gt 1000 ]; then
+      echo "*** File $fp truncated to 1000 lines, was $WCL lines. ***"
+      echo "*** File $fp truncated to 1000 lines, was $WCL lines. ***" >> ${TMPDIR}/fpaste-output_${DS}.txt
+    fi
+    /usr/bin/head -n1000 $fp >> ${TMPDIR}/fpaste-output_${DS}.txt
+  fi
+done
+echo fpaste ${TMPDIR}/fpaste-output_${DS}.txt
+
+if [ "x$1" != "xNOPOST" ]; then
+  /usr/bin/fpaste ${TMPDIR}/fpaste-output_${DS}.txt
+fi
+
+#EOF
diff --git a/script-test.pl b/script-test.pl
new file mode 100755
index 0000000..a83c4c8
--- /dev/null
+++ b/script-test.pl
@@ -0,0 +1,210 @@
+# !/usr/bin/perl -Tw
+# -*- perl -*-
+# via https://github.com/munin-monitoring/contrib/blob/master/t/test.t
+
+use strict;
+use warnings;
+
+use Test::More;
+use File::Find ();
+use Capture::Tiny ':all';
+
+use vars qw/*name *dir *prune/;
+*name  = *File::Find::name;
+*dir   = *File::Find::dir;
+*prune = *File::Find::prune;
+my $num_plugins = 0;
+
+sub wanted
+{
+    my ($dev, $ino, $mode, $nlink, $uid, $gid, $interpreter, $arguments);
+
+    (($dev, $ino, $mode, $nlink, $uid, $gid) = lstat($_))
+      && -f _
+      && (($interpreter, $arguments) = hashbang("$_"))
+      && ($interpreter)
+      && ++$num_plugins
+      && process_file($_, $name, $interpreter, $arguments);
+}
+
+File::Find::find({wanted => \&wanted}, 'plugins');
+
+sub hashbang
+{
+    my ($filename) = @_;
+    open my $file, '<', $filename;
+    my $firstline = <$file>;
+    close $file;
+
+    $firstline =~ m{ ^\#!                    # hashbang
+                     \s*                     # optional space
+                     (?:/usr/bin/env\s+)?    # optional /usr/bin/env
+                     (?<interpreter>\S+)     # interpreter
+                     (?:\s+
+                         (?<arguments>[^\n]*)   # optional interpreter arguments
+                     )?
+               }xms;
+
+    return ($+{interpreter}, $+{arguments});
+}
+
+sub process_file
+{
+    my ($file, $filename, $interpreter, $arguments) = @_;
+    use v5.10.1;
+
+    if ($interpreter =~ m{/bin/sh})
+    {
+        subtest $filename => sub {
+            plan tests => 2;
+            run_check(
+                      {
+                       command     => ['sh', '-n', $file],
+                       description => 'sh syntax check'
+                      }
+                     );
+            run_check(
+                      {
+                       command     => ['checkbashisms', $file],
+                       description => 'checkbashisms'
+                      }
+                     );
+        };
+    }
+    elsif ($interpreter =~ m{/bin/ksh})
+    {
+        run_check(
+                  {
+                   command     => ['ksh', '-n', $file],
+                   description => 'ksh syntax check',
+                   filename    => $filename
+                  }
+                 );
+    }
+    elsif ($interpreter =~ m{bash})
+    {
+        run_check(
+                  {
+                   command     => ['bash', '-n', $file],
+                   description => 'bash syntax check',
+                   filename    => $filename
+                  }
+                 );
+    }
+    elsif ($interpreter =~ m{perl})
+    {
+        my $command;
+        if ($arguments =~ m{-.*T}mx)
+        {
+            $command = ['perl', '-cwT', $file];
+        }
+        else
+        {
+            $command = ['perl', '-cw', $file];
+        }
+        run_check(
+                  {
+                   command     => $command,
+                   description => 'perl syntax check',
+                   filename    => $filename
+                  }
+                 );
+    }
+    elsif ($interpreter =~ m{python})
+    {
+        run_check(
+                  {
+                   command     => ['python', '-m', 'py_compile', $file],
+                   description => 'python compile',
+                   filename    => $filename
+                  }
+                 );
+    }
+    elsif ($interpreter =~ m{php})
+    {
+        run_check(
+                  {
+                   command     => ['php', '-l', $file],
+                   description => 'php syntax check',
+                   filename    => $filename
+                  }
+                 );
+    }
+    elsif ($interpreter =~ m{j?ruby})
+    {
+        run_check(
+                  {
+                   command     => ['ruby', '-cw', $file],
+                   description => 'ruby syntax check',
+                   filename    => $filename
+                  }
+                 );
+    }
+    elsif ($interpreter =~ m{gawk})
+    {
+        run_check(
+                  {
+                   command => [
+                               'gawk', '--source',
+                               'BEGIN { exit(0) } END { exit(0) }',
+                               '--file', $file
+                              ],
+                   description => 'gawk syntax check',
+                   filename    => $filename
+                  }
+                 );
+    }
+    elsif ($interpreter =~ m{expect})
+    {
+      SKIP:
+        {
+            skip 'no idea how to check expect scripts', 1;
+            pass("No pretending everything is ok");
+        }
+    }
+    else
+    {
+        fail($filename . " unknown interpreter " . $interpreter);
+    }
+}
+
+sub run_check
+{
+    my ($args)        = @_;
+    my $check_command = $args->{command};
+    my $description   = $args->{description};
+    my $filename      = $args->{filename};
+
+    my $message;
+
+    if ($filename)
+    {
+        $message = sprintf('%s: %s', $filename, $description);
+    }
+    else
+    {
+        $message = $description;
+    }
+
+    my ($stdout, $stderr, $exit) = capture
+    {
+        system(@{$check_command});
+    };
+
+    ok(($exit == 0), $message);
+
+    if ($exit)
+    {
+        diag(
+             sprintf(
+                     "\nCommand: %s\n\nSTDOUT:\n\n%s\n\nSTDERR:\n\n%s\n\n",
+                     join(" ", @{$check_command}),
+                     $stdout, $stderr
+                    )
+            );
+    }
+}
+
+done_testing($num_plugins);
+
+#EOF
diff --git a/simple_qos.sh b/simple_qos.sh
index 0739181..0739181 100644..100755
--- a/simple_qos.sh
+++ b/simple_qos.sh
diff --git a/trimtrees.pl b/trimtrees.pl
new file mode 100755
index 0000000..8bbc728
--- /dev/null
+++ b/trimtrees.pl
@@ -0,0 +1,329 @@
+#!/usr/bin/perl -w
+
+use strict;
+use Cwd;
+use Digest::MD5 qw(md5);
+use Dumpvalue;
+use File::Compare qw(compare);
+use File::Copy qw(cp);
+use File::Find;
+use File::Temp qw(tempfile);
+use Getopt::Long;
+our %Opt;
+GetOptions(\%Opt, "maxlinks=i",) or die;
+
+my @dirs = @ARGV or die "Usage: $0 OPTIONS directories";
+our $DEBUG  = 0;
+our $Signal = 0;
+our %MD5;
+our $Usedspc  = 0;
+our $Savedspc = 0;
+
+$SIG{INT} = sub {
+    warn "Caught SIGINT; please stand by, I'm leaving as soon as possible...\n";
+    $Signal++;
+};
+our $DV = Dumpvalue->new(
+                         tick         => qq{"},
+                         quoteHighBit => 1,
+                         printUndef   => 1,
+                        );
+our $WD = Cwd::cwd;
+
+sub fmt ($)
+{
+    local $_ = shift;
+    s/(\d)(?=(\d{3})+$)/$1_/g;
+    $_;
+}
+
+# $success = melt($some_file,$another)
+
+# $some_file is always absolute, $another is always in the current
+# directory
+
+# melt dies on severe errors, returns 1 on success and 0 if it could
+# not melt the files. It warns on suspect error conditions, but does
+# not warn if they have no severe consequences.
+sub melt ($$)
+{
+    my ($first, $basename) = @_;
+    my ($fh, $tempfile) = tempfile("trimtrees1-XXXXXXXX", DIR => ".");
+    unless ($tempfile)
+    {
+        die "Could not create a temporary file: $!";
+    }
+    unless (rename $basename, $tempfile)
+    {
+        warn sprintf("Cannot rename %s to %s (%s); Skipping.",
+                     $DV->stringify($basename),
+                     $DV->stringify($tempfile), $!,);
+        unlink $tempfile or die "Could not unlink '$tempfile': $!";
+        return 0;
+    }
+    unless (link $first, $basename)
+    {
+        my $link_err = $!;
+        if (rename $tempfile, $basename)
+        {
+            # We could rename back and no harm should be done. Don't warn.
+            return 0;
+        }
+        else
+        {
+            die sprintf(
+                        "Could neither link %s to %s (%s) "
+                          . "nor rename %s back to %s (%s).",
+                        $DV->stringify($first),    $DV->stringify($basename),
+                        $link_err,                 $DV->stringify($tempfile),
+                        $DV->stringify($basename), $!
+                       );
+        }
+    }
+    close $fh or warn "Could not close the temporary filehandle: $!";
+    unless (unlink $tempfile)
+    {
+        die sprintf("Could not unlink %s (was %s): %s",
+                    $DV->stringify($tempfile),
+                    $DV->stringify($basename), $!);
+    }
+    return 1;
+}
+
+{
+    my %INODE;
+
+    sub register ($$;$)
+    {
+        my ($md5, $cand, $candstat) = @_;
+        $MD5{$md5} = $cand;
+        my @stat = $candstat ? @$candstat : stat $cand;
+        my $size = $stat[7];
+        warn "size undefined"    unless defined $size;
+        warn "usedspc undefined" unless defined $Usedspc;
+        if ($DEBUG)
+        {
+            warn(sprintf "\nDEBUG: cand[%s]size[%s]stat[%s]",
+                 $cand, $size, join(":", @stat));
+        }
+        return if $INODE{$stat[1]}++;    # don't count twice
+        $Usedspc += $size;
+    }
+}
+
+undef $/;
+my %reported;
+my $files         = 0;
+my $dirs          = @dirs;
+my $tl_dirs_todo  = 0;
+my $tl_dirs_doing = 0;
+
+sub xreport ()
+{
+    my $uniq_files = keys %MD5;
+    printf(
+           "\rtlds[%s]cur[%s]uniq[%s]fils[%s]spcused[%s]saved[%s]",
+           map { fmt($_) } (
+                            $tl_dirs_todo, $tl_dirs_doing, $uniq_files,
+                            $files,        $Usedspc,       $Savedspc
+                           )
+          );
+}
+
+$| = 1;
+for my $diri (0 .. $#dirs)
+{
+    my $root = $dirs[$diri];
+    find(
+        {
+         wanted => sub {
+             if ($Signal)
+             {
+                 $File::Find::prune = 1;
+                 return;
+             }
+             if ($File::Find::name eq $root)
+             {
+                 my $td = $_;
+                 opendir my ($dh), $td;
+                 my (@tl) = grep { !/^\./ && -d "$td/$_" } readdir $dh;
+                 $tl_dirs_todo = @tl;
+             }
+             elsif (-d)
+             {
+                 my $slashes = $File::Find::name =~ tr|/||;
+                 if ($slashes == 1)
+                 {
+                     $tl_dirs_doing++;
+                 }
+             }
+             return
+               if
+               -l; # relative links would need special treatment that does not pay off
+             return unless -f _;
+             return unless -s _;    # empty files more risk that files with
+                                    # content and no gain
+             $files++;
+             my $basename = $_;
+             my $fh;
+
+             unless (open $fh, "<", $basename)
+             {
+                 warn sprintf("Cannot read %s (%s); Skipping.",
+                              $DV->stringify($File::Find::name), $!,);
+                 $Usedspc += -s $basename;
+                 return;
+             }
+             my $data = <$fh>;
+             close $fh;
+             my $md5  = md5 $data;
+             my $cand = $File::Find::name;
+             if ($Opt{maxlinks})
+             {
+                 my (@maxlstat) = stat($cand);
+                 if ($maxlstat[3] > $Opt{maxlinks})
+                 {
+                     # the case that we have to make a new file from a link
+                     my ($fh, $tempfile) =
+                       tempfile("trimtrees2-XXXXXXXX", DIR => ".");
+                     unless ($tempfile)
+                     {
+                         die "Could not create a temporary file: $!";
+                     }
+                     unless (rename $cand, $tempfile)
+                     {
+                         die sprintf("Could not rename %s to %s: %s",
+                                     $DV->stringify($cand),
+                                     $DV->stringify($tempfile), $!);
+                     }
+                     cp $tempfile,
+                       $cand
+                       or die sprintf("Could not cp %s to %s: %s",
+                                      $DV->stringify($tempfile),
+                                      $DV->stringify($cand), $!,);
+                     unlink $tempfile;
+                     $Savedspc -= $maxlstat[7];
+                 }
+             }
+             if (my $first = $MD5{$md5})
+             {
+                 unless (File::Spec->file_name_is_absolute($first))
+                 {
+                     $first = File::Spec->catfile($WD, $first);
+                 }
+                 my (@firststat) = stat($first);
+                 die sprintf("illegal firststat[%s]first[%s]",
+                             join(":", @firststat), $DV->stringify($first),)
+                   unless $firststat[1];
+                 my $different = compare $first, $basename;
+                 if ($different != 0 && $File::Compare::VERSION < 1.1005)
+                 {
+                     # workaround bug # 37716 in File::Compare
+                     $different = compare "$first\0", "$basename\0";
+                 }
+                 if ($different < 0)
+                 {
+                     warn sprintf("Cannot compare %s and %s (%s); Skipping.",
+                                  $DV->stringify($first),
+                                  $DV->stringify($cand), $!,);
+                     goto XREPORT;    # some error occurred
+                 }
+                 die sprintf("Sensation, %s and %s are not equal with same MD5",
+                             $DV->stringify($first), $DV->stringify($cand),)
+                   if $different;
+                 my (@candstat) = stat($basename);
+                 goto XREPORT
+                   unless $candstat[0] == $firststat[0]; # different file system
+                 if ($candstat[1] == $firststat[1])
+                 {                                       # already same inode
+                     if (0 && $Opt{maxlinks} && $firststat[3] > $Opt{maxlinks})
+                     {
+                     }
+                     else
+                     {
+                         goto XREPORT;
+                     }
+                 }
+                 if ($Opt{maxlinks} && $firststat[3] >= $Opt{maxlinks})
+                 {
+                     register($md5, $cand, \@candstat)
+                       if $candstat[3] < $Opt{maxlinks};
+                 }
+                 elsif (melt($first, $basename))
+                 {
+                     if ($candstat[3] == 1)
+                     {    # we don't save space otherwise
+                         $Savedspc += $firststat[7];
+                     }
+                 }
+                 else
+                 {
+                     register($md5, $cand, \@candstat);
+                 }
+             }
+             else
+             {
+                 register($md5, $cand);
+             }
+           XREPORT:
+             return if $files % 100;
+             xreport;
+         },
+         no_chdir => 1,
+        },
+        $root
+        );
+    last if $Signal;
+}
+xreport;
+print "\nDONE\n";
+
+__END__
+
+=head1 NAME
+
+trimtrees - traverse directories, find identical files, replace with hard links
+
+=head1 SYNOPSIS
+
+ trimtrees.pl OPTIONS directory...
+
+ OPTIONS:
+
+  --maxlinks N            limit the amount of links per file
+
+=head1 DESCRIPTION
+
+Traverse all directories named on the command line, compute MD5
+checksums and find files with identical MD5. IF they are equal, do a
+real comparison if they are really equal, replace the second of two
+files with a hard link to the first one.
+
+Special care is taken to cope with C<Too many links> error conditions.
+The inode that is overbooked in such a way, is taken out of the pool
+and replaced with the another one such that the minimum of files
+needed is kept on disk.
+
+The C<--maxlinks> option can be used to reduce the linkcount on all
+files within a tree, thus preparing the tree for a subsequent call to
+C<cp -al>. This operation can be thought of the reverse of the normal
+trimtrees operation (--maxlinks=1 produces a tree without hard links).
+
+=head1 SIGNALS
+
+SIGINT is caught and the script stops as soon as the current file
+is finished.
+
+=head2 RISKS
+
+The whole idea of replacing identical files with hard links has
+inherent dangers. Once two files have turned into one inode other
+processes may accidentally change both although they intend to alter
+only one. Please consider if this can happen in your environment.
+
+=cut
+
+	Local Variables:
+	mode: cperl
+	cperl-indent-level: 2
+	End: