You can cut-n-paste the code below or you can |
#!/usr/local/bin/perl -w
#
# SccsId[] = "@(#)linkcheck.pl 1.3 01/08/03 (Link check Perl program)"
#
#----------------------------------------------------------------------#
# linkcheck.pl #
# -------------------------------------------------------------------- #
# #
# Copyright (c) 2002-2007 by Bob Orlando. All rights reserved. #
# #
# Permission to use, copy, modify and distribute this software #
# and its documentation for any purpose and without fee is hereby #
# granted, provided that the above copyright notice appear in all #
# copies, and that both the copyright notice and this permission #
# notice appear in supporting documentation, and that the name of #
# Bob Orlando not be used in advertising or publicity pertaining #
# to distribution of the software without specific, written prior #
# permission. Bob Orlando makes no representations about the #
# suitability of this software for any purpose. It is provided #
# "as is" without express or implied warranty. #
# #
# BOB ORLANDO DISCLAIMS ALL WARRANTIES WITH REGARD TO THIS #
# SOFTWARE, INCLUDING ALL IMPLIED WARRANTIES OF MERCHANTABILITY #
# AND FITNESS. IN NO EVENT SHALL BOB ORLANDO BE LIABLE FOR ANY #
# SPECIAL, INDIRECT OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES #
# WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER #
# IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, #
# ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF #
# THIS SOFTWARE. #
# #
# -------------------------------------------------------------------- #
# Program documentation and notes located at the bottom. #
#----------------------------------------------------------------------#
BEGIN { $diagnostics::PRETTY = 1 }
$SIG{'INT'}=sub {print "\nExiting on $SIG{'INT'}\n";exit $SIG{'INT'}};
use File::Find;
use Getopt::Std;
use Cwd;
use POSIX qw(uname);
my $host = (uname)[1];
$| = 1; # Autoflush (unbuffer output)
use vars qw($opt_a $opt_H $opt_h $opt_l $opt_r $opt_v);
my $options='aHhlrv';
exit_usage("Invalid option!\n") unless (getopts($options));
show_documentation() if ($opt_H); # Full documentation
exit_usage() if ($opt_h); # or usage brief.
exit_usage("Filesystem required.\n") if ($#ARGV < 0);
if ($opt_v)
{
use diagnostics;
}
#---------------------------------------------------------#
# Eliminate all but local filesystem searches right away. #
#---------------------------------------------------------#
my $local_fs;
my @search;
foreach (@ARGV)
{
if ($local_fs = `df -lk $_`)
{
push(@search, $_);
}
else
{
print "File system $_ must be local to $host, not NFS mounted.",
"\nSkipping $_.\n";
$_ = "";
}
}
#-------------------------------------------------------------#
# Ignore find command's stderr output (eliminates "Permission #
# denied" and most--not ALL--other bothersome messages). #
#-------------------------------------------------------------#
open(OLDERR, ">&STDERR");
open(STDERR, ">/dev/null") or die "Can't redirect stderr: $!";
my $q = 0; # Found counter
my $r = 0; # Removed counter
find sub # [Anonymous] subroutine reference (called a coderef).
{
return unless -l "$_"; # Skip all but links.
#----------------------------------------------------------#
# Skip nfs mounted links, and /proc and /cdrom pathnames. #
#----------------------------------------------------------#
return if (
(lstat("$_"))[0] < 0
||
$File::Find::name =~ /\/proc/s
||
$File::Find::name =~ /\/cdrom/s
);
#----------------------------------------------------------#
# Skip link if it's not on a local filesystem as well. #
#----------------------------------------------------------#
my $dir = cwd;
return unless ($local_fs = `df -lk $dir`);
$! = 0; # Clear error message variable
return unless defined(my $target = readlink("$_"));
my $error = "$!";
$error = "($error)" if (defined($error) && $error ne "");
my $ls_out = ($opt_l)
? `ls -albd $File::Find::name 2> /dev/null`
: "$File::Find::name -> $target";
chomp($ls_out);
unless (-e "$target") # Unless the link is OK, do the following.
{
$q++;
print "Broken link: $ls_out $error\n";
if ($opt_r)
{
print "rm '$File::Find::name'\n";
if (unlink("$File::Find::name") == 0) # Zero = none deleted.
{
print "Unable to remove $File::Find::name!\n";
return;
}
$r++;
print "Removed '$File::Find::name'\n" if ($opt_v);
}
return;
}
#----------------------------------------------------------#
# Return unless user requests list of all links (-a). #
#----------------------------------------------------------#
return unless ($opt_a);
if (-f "$target") { print "Linked file: $ls_out $error\n"; }
elsif (-d "$target") { print "Linked dir: $ls_out $error\n"; }
elsif (-l "$target") { print "Linked link: $ls_out $error\n"; }
elsif (-p "$target") { print "Linked pipe: $ls_out $error\n"; }
elsif (-S "$target") { print "Linked sock: $ls_out $error\n"; }
elsif (-b "$target") { print "Linked dev: $ls_out $error\n"; }
elsif (-c "$target") { print "Linked char: $ls_out $error\n"; }
elsif (-t "$target") { print "Linked tty: $ls_out $error\n"; }
else { print "Linked ???: $ls_out $error\n"; }
$error = "";
return;
}, @search; # find sub
#-------------------------------------------------------------#
# Restore stderr. #
#-------------------------------------------------------------#
close(STDERR) or die "Can't close STDERR: $!";
open( STDERR, ">&OLDERR") or die "Can't restore stderr: $!";
close(OLDERR) or die "Can't close OLDERR: $!";
print "$host: Found $q broken links. Removed $r.\n";
exit 1;
#======================================================================#
# S U B R O U T I N E S / F U N C T I O N S #
# (in alphabetical order) #
#----------------------------------------------------------------------#
sub exit_usage # Exits with non-zero status. #
# Global vars: $main::notify #
# $main::support #
#----------------------------------------------------------------------#
{
my $fn_name = "exit_usage";
my $txt ;
#---------------------------------------------------------------#
# Assign to private variable, $notify either $main::support or #
# $main::notify (takes $main::support over $main::notify). #
#---------------------------------------------------------------#
my $notify;
if (defined($ENV{LOGNAME} )) { $notify = $ENV{LOGNAME}; }
else { $notify = $ENV{USER}; }
$txt = "Usage: $0 -$options fs ...\n";
$txt = "$_[0]\n$txt" if ($#_ >= 0); # Prefix message arguments
$txt .= "\n -a = Display All links."
. "\n -H = Displays full documentation."
. "\n -h = Gives usage brief."
. "\n -l = Long list (e.g. 'ls -al')."
. "\n -r = Remove broken links (use with caution)."
. "\n -v = Verbose output."
. "\n fs = Required filesystem for search."
. "\n (multiple filesystems may be specified)\n"
. "\nPurpose: Search filesystem (descending directories) for"
. "\n broken links, optionally displaying all links"
. "\n (-a) and/or removing (-r) them.\n";
#---------------------------------------------------------------#
# If running interactively, then give'm usage, else notify #
# program support person(s) because a cron'd job called usage. #
#---------------------------------------------------------------#
print "$txt";
exit 1;
} # sub exit_usage
#----------------------------------------------------------------------#
sub show_documentation # Display program documentation at bottom. #
#----------------------------------------------------------------------#
{
my $n = 0;
foreach (my @doc_lines = <main::DATA>)
{
print "$_";
}
exit $n;
} # sub show_documentation
__END__ # Documentation section follows:
#======================================================================#
# D O C U M E N T A T I O N #
#======================================================================#
# #
# Author: Bob Orlando #
# #
# Date: April 29, 2002 #
# #
# Program ID: linkcheck.pl #
# #
# Purpose: Search local filesystem or systems #
# (descending directories) for broken #
# links, optionally displaying all links #
# (-a) and/or removing (-r) them. #
# #
# Usage: linkcheck.pl -aHhlrv fs ... #
# -a = Display All links. #
# -H = Detailed documentation. #
# -h = Usage brief. #
# -l = Long list (e.g. 'ls -al'). #
# -r = Remove broken links #
# (use with caution). #
# -v = Verbose output. #
# fs = Required filesystem for search #
# (multiple filesystems may be #
# specified) #
# #
# Examples: linkcheck.pl / # Lists broken links (short list) #
# linkcheck.pl -l / # Lists broken links (long list) #
# linkcheck.pl -a /home # Lists all links in /home. #
# linkcheck.pl -r /usr # Removes broken links from /usr. #
# #
# Returns: Zero on success. #
# Nonzero in failure. #
# #
# Files: .................................................... #
# .................................................... #
# #
# Notes: .................................................... #
# .................................................... #
# #
# Modified: 2003-01-08 Bob Orlando #
# v1.3 * Force autoflush (unbuffer output). #
# #
# 2002-06-14 Bob Orlando #
# v1.2 * Add tally of links found and removed. #
# * Add host name to messages. #
# * Initialize counters $q and $r to 0; #
# #
# 2002-06-04 Bob Orlando #
# v1.1 * Initial SCCS release. #
# #
#----------------------------------------------------------------------#
| ©Copyright Bob Orlando, 2002-2007. All rights reserved. |
http://www.OrlandoKuntao.com E-mail: Bob@OrlandoKuntao.com |
Last update:
Sep. 16, 2007 by Bob Orlando |