#!/usr/local/bin/perl
#
# Checklinks 1.0.1
#
# Starting at one or more seed HTML files, recursively check the
# validity of all links on the site. Major features:
#
# * Local URLs are read from the filesystem when possible (much
# faster than going through HTTP server).
# * Basic server-side includes (aka SSI or SHTML) are checked.
# * Latest standards are supported-- HTML 4.0, HTTP 1.1, URIs
# according to RFC 2396.
# * Links are traversed breadth-first.
#
# To list command-line options, run "cl -?" or see &usage() below.
#
# TO CONFIGURE:
#
# 1) Set $LOCAL_HOST and $DOCUMENT_ROOT, just below. If you don't, the
# program will try to guess them in set_needed_globals(), but it's more
# reliable if you enter them here.
#
# 2) If needed, set any further server configuration below-- things like
# path aliases and so forth. If you have the srm.conf file, you can
# feed it into this script with "-c srm.conf"; otherwise, the default
# settings will probably work OK.
#
# You can set a few parameters with the undocumented "-D <name=value>"
# command-line option, e.g. "-D LOCAL_HOST=www.myhost.com".
#
# Further comments, including an overview of script internals, are at
# the end of this file.
#
# Copyright (C) 1998, 2000 by James Marshall, james@jmarshall.com
# see http://www.jmarshall.com/tools/cl/ for more info
#
#
# CHANGES IN 1.0.1:
#
# This is just a bug fix release. Fixes include:
# . Aliases are handled correctly now. Sorry 'bout that.
# . A redirect + relative URL no longer results in infinitely
# recursing URLs.
# . More HTML tags are searched for links.
# . Non-HTML files are no longer searched for links.
# . There were other minor bug fixes.
#
#----------------------------------------------------------------------
#use strict ;
my( $LOCAL_HOST, $DOCUMENT_ROOT, $USER_DIR, @DIRECTORY_INDEX,
%ALIAS, %ALIAS_MATCH, %SCRIPT_ALIAS, %SCRIPT_ALIAS_MATCH, %UN_ALIAS,
@SHTML_EXTENSIONS, @CGI_EXTENSIONS, @INCLUDE_PATTERNS, @EXCLUDE_PATTERNS,
@INCLUDE_STATUS, @EXCLUDE_STATUS,
$verbose_report, $max_depth, $file_check, $full_http_check,
$MAX_REDIRECTS, $MAX_ATTEMPTS, $HTML_BY_NAME, $SUPPORT_NCSA_BUG,
@NO_PROXY, $DOC_ROOT_DEV, $DOC_ROOT_INODE, $DOC_ROOT_EXISTS, $CWD,
%html_urls, %non_html_urls, %e_to_ch,
%home_dir, %dir_to_user, %inode_to_user,
%url, @urlstoget,
$debug, $CL_VERSION,
) ;
#----- User Configuration ---------------------------------------------
# This should be 'localhost', or a hostname of the Web server. URLs at
# this host will be assumed to be local; URLs not at this host will not be
# traversed into. If this names a remote host, the program will not work.
# Note that 'localhost' doesn't necessarily point to your local Web server.
# $LOCAL_HOST= 'localhost' ;
# $LOCAL_HOST= 'www.example.com' ;
$LOCAL_HOST='isabelle.in.tum.de';
# This is your root Web directory, i.e. the directory that the Web server
# sends the user if the URL "http://$LOCAL_HOST" is requested. It's in
# the configuration file srm.conf (and is read by -c option).
# If you don't know the document root of your server, but you don't need
# it because you're only checking URLs whose path starts with ~, put a
# non-existent path here rather than leave it blank (a hack).
# $DOCUMENT_ROOT= '/home/www/htdocs' ;
$DOCUMENT_ROOT='/home/proj/isabelle';
#----- variables equivalent to srm.conf entries
# These globals are from the equivalent entries in srm.conf, etc.
# See the command-line option -c <config-file>, to read values directly
# from srm.conf instead.
# $USER_DIR= 'public_html' ;
$USER_DIR='.html-data';
@DIRECTORY_INDEX= qw( index.html index.cgi index.shtml ) ;
# Used in &url_to_filename(), and possibly elsewhere
# Note that ALIAS_MATCH and SCRIPT_ALIAS_MATCH use Perl (not standard) regexps.
# If order of multiple e.g. "Alias" directives is important, this may not work.
%ALIAS= () ;
%ALIAS_MATCH= () ;
%SCRIPT_ALIAS= () ;
%SCRIPT_ALIAS_MATCH= () ;
# The list of file extensions to interpret as CGI scripts or
# server-parsed HTML files.
# These are not specific settings in srm.conf, but are combinations of
# AddHandler directives and possibly AddType directives.
@CGI_EXTENSIONS= qw( .cgi ) ;
@SHTML_EXTENSIONS= qw( .shtml ) ;
#----- end of variables equivalent to srm.conf entries
# Specify patterns here to only include URLs that match at least one
# pattern. As a special case, an empty list includes all URLs, i.e.
# does not restrict URLs by name (except perhaps by @EXCLUDE_PATTERNS).
# This can be added to or cleared with the -I command-line option.
@INCLUDE_PATTERNS= () ;
# Specify patterns here to cause matching URLs to be excluded,
# e.g. '\?' means ignore all URLs that query.
# This can be added to or cleared with the -X command-line option.
# @EXCLUDE_PATTERNS= qw( \? ) ;
# Only report URLs whose status codes start with one of these patterns.
# As a special case, an empty list reports all URLs, i.e. does not
# restrict URLs by status code (except perhaps by @EXCLUDE_STATUS).
# This can be added to or cleared with the -i command-line option.
@INCLUDE_STATUS= () ;
# Don't report URLs whose status codes start with these patterns. Default
# is qw( 200 ).
# This can be added to or cleared with the -x command-line option.
@EXCLUDE_STATUS= qw( 200 ) ;
# For 302 or 303 HTTP redirection, redirect no more than this many times.
$MAX_REDIRECTS= 5 ;
# If a connection times out, etc., attempt no more than this many times.
$MAX_ATTEMPTS= 5 ;
# The old version determined whether a file was HTML by the -T test (text
# file), and so traversed all HTML-like links in any text file that wasn't
# a CGI script. It's probably more appropriate to check the file
# extension, to exclude source code, .txt files, etc. Leave $HTML_BY_NAME
# set to use the filename, or unset it to traverse all HTML-like links in
# any text files, as the old version did.
$HTML_BY_NAME= 1 ;
# Some old NCSA servers, including 1.5.2, don't report the HTTP version
# correctly in the status line; they return e.g. "HTTP 200 OK". To allow
# this, leave the variable here set.
$SUPPORT_NCSA_BUG= 1 ;
#----- DO NOT CHANGE ANYTHING BELOW THIS LINE, unless you want to... ---
#----- Further Global Variable Initialization --------------------------
$CL_VERSION= '1.0.1' ;
$ENV{'http_proxy'}||= $ENV{'HTTP_PROXY'} ;
@NO_PROXY= split(/[\s,]+/, $ENV{'no_proxy'} || $ENV{'NO_PROXY'} ) ;
# If output's not going directly to terminal, this ensures autoflushing.
$|= 1 ;
#----- End of Configuration --------------------------------------------
use strict 'vars' ;
use IO::Socket ;
&usage unless @ARGV ;
# Process command-line options
&getopts ;
# Make any final needed adjustments to globals, after the hard-coded
# values above and any options have been processed.
&adjust_all_globals ;
# Default to "." if no starting filenames given.
# 3-6-98: Anh, decided against it.
#@ARGV= ('.') unless @ARGV ;
# &add_url() sets $url{$_} and pushes to @urlstoget, only if not already
# added, plus any other initialization.
# Only add a file if it can be accessed with a URL.
foreach my $arg (@ARGV) {
if ($arg=~ m#^http://#i) {
&add_url($arg, '-', 0) ;
} else {
my($URL)= &filename_to_url($arg, $CWD) ;
if (defined($URL)) {
&add_url($URL, '-', 0) ;
} else {
die "ERROR: $arg is not accessible through the Web server.\n" ;
}
}
}
# Check the URLs, in order. @urlstoget may grow and rearrange.
while (@urlstoget) {
my($url)= shift(@urlstoget) ;
if ( !$url->{'ishtml'} or !$url->{'islocal'} or $url->{'dontfollow'}
or (length($max_depth) and $url->{'depth'} > $max_depth ) ) {
&verify_url($url) ; # may set ishtml=true
}
if ( $url->{'ishtml'} and $url->{'islocal'} and !$url->{'dontfollow'}
and (!length($max_depth) or $url->{'depth'} <= $max_depth ) ) {
my($HTML)= &load_url($url) ; # may set ishtml=false
# 11-30-99 JSM: fixed to handle rel URLs in redirected pages correctly
my($base_url)= $url->{'location'} || $url->{'URL'} ;
&extract_urls($HTML, $base_url, $url->{'URL'}, $url->{'depth'}+1)
if $url->{'ishtml'} ; # big, calls &add_url()
}
# If we get an error response that may be corrected with another
# attempt, put it back in the queue. Such errors include 408,
# 503, 504, and the homegrown codes 600, 601, 602, and 603.
if ($url->{'status'}=~ /^(408|503|504|600|601|602|603)\b/ ) {
push(@urlstoget, $url) if ( $url->{'numtries'} < $MAX_ATTEMPTS ) ;
}
}
&make_report() ;
exit ;
#----- Process command-line options -----------------------------------
# Process any command-line options.
sub getopts {
my($opt, $param) ;
while ($ARGV[0]=~ /^-/) {
$opt= shift(@ARGV) ;
($opt, $param)= $opt=~ /^-(.)(.*)/ ;
# Turn on verbose reporting
if ($opt eq 'v') {
$verbose_report= ($param ne '-') ;
# User-specified patterns to exclude ('' to clear list)
} elsif ($opt eq 'I') {
$param= shift(@ARGV) unless length($param) ;
if (length($param)) { push(@INCLUDE_PATTERNS, $param) }
else { @INCLUDE_PATTERNS= () }
# User-specified patterns to exclude ('' to clear list)
} elsif ($opt eq 'X') {
$param= shift(@ARGV) unless length($param) ;
if (length($param)) { push(@EXCLUDE_PATTERNS, $param) }
else { @EXCLUDE_PATTERNS= () }
# User-specified response codes to ignore ('' to clear list)
} elsif ($opt eq 'i') {
$param= shift(@ARGV) unless length($param) ;
if (length($param)) { push(@INCLUDE_STATUS, $param) }
else { @INCLUDE_STATUS= () }
# User-specified response codes to ignore ('' to clear list)
} elsif ($opt eq 'x') {
$param= shift(@ARGV) unless length($param) ;
if (length($param)) { push(@EXCLUDE_STATUS, $param) }
else { @EXCLUDE_STATUS= () }
# Maximum traversal depth
} elsif ($opt eq 'd') {
$param= shift(@ARGV) unless length($param) ;
$max_depth= $param ;
# Make it a "file check"-- only read local files, do not use HTTP
} elsif ($opt eq 'f') {
$file_check= ($param ne '-') ;
# Use HTTP for all URL's, even local files
} elsif ($opt eq 'h') {
$full_http_check= ($param ne '-') ;
# Read configuration parameters from srm.conf-like file
} elsif ($opt eq 'c') {
$param= shift(@ARGV) unless length($param) ;
&read_srm_conf($param) ;
# Print current configuration parameters
} elsif ($opt eq 'q') {
&print_config ;
exit ; # jsm-- should we exit?
# Allow certain parameters to be defined via the command line
} elsif ($opt eq 'D') {
$param= shift(@ARGV) unless length($param) ;
$debug=1, unshift(@ARGV,$param), next if $param=~ /^-/ ;
my($name,$value)= split(/=/, $param, 2) ;
$value= 1 unless length($value) ;
if ($name=~ /^(LOCAL_HOST|DOCUMENT_ROOT|USER_DIR|DEBUG|debug)$/) {
eval "\$$name= \$value" ;
#$$name= $value ; # this doesn't work, because of initial my()
}
} elsif ($opt eq '?') {
&usage ;
# End command-line option processing on "--"
} elsif ($opt eq '-') {
return ;
} else {
print STDERR
"Illegal option-- '$opt'. Enter \"$0 -?\" for help.\n" ;
exit ;
}
}
if ($file_check and $full_http_check) {
print STDERR "You cannot use both the -f and the -h options.\n" ;
exit ;
}
}
# Read appropriate values from the given file, typically srm.conf. If a
# directory is named, default to filename "srm.conf".
# Note that opening "-" will open STDIN.
sub read_srm_conf {
my($fname)= @_ ;
local(*SRM) ;
# default to srm.conf if only a directory is named
if (-d $fname) {
$fname=~ s#/$## ;
$fname.= "/srm.conf" ;
}
# Clear old values
$DOCUMENT_ROOT= $USER_DIR= '' ;
@DIRECTORY_INDEX= @CGI_EXTENSIONS= @SHTML_EXTENSIONS= () ;
%ALIAS= %ALIAS_MATCH= %SCRIPT_ALIAS= %SCRIPT_ALIAS_MATCH= () ;
open(SRM, "<$fname") || die "Can't open $fname: $!" ;
while (<SRM>) {
s/#.*// ;
next unless /\S/ ;
my($name, @param)= /(\S+)/g ;
if ($name eq 'DocumentRoot') {
$DOCUMENT_ROOT= $param[0] ;
} elsif ($name eq 'UserDir') {
$USER_DIR= $param[0] ;
} elsif ($name eq 'DirectoryIndex') {
@DIRECTORY_INDEX= @param ;
} elsif ($name eq 'Alias') {
$ALIAS{$param[0]}= $param[1] ;
} elsif ($name eq 'AliasMatch') {
$ALIAS_MATCH{$param[0]}= $param[1] ;
} elsif ($name eq 'ScriptAlias') {
$SCRIPT_ALIAS{$param[0]}= $param[1] ;
} elsif ($name eq 'ScriptAliasMatch') {
$SCRIPT_ALIAS_MATCH{$param[0]}= $param[1] ;
} elsif ($name eq 'AddHandler') {
if ($param[0] eq 'cgi-script') {
push(@CGI_EXTENSIONS, $param[1]) ;
} elsif ($param[0] eq 'server-parsed') {
push(@SHTML_EXTENSIONS, $param[1]) ;
}
}
}
close(SRM) ;
}
# Make any final settings to global variables, after the hard-coded values
# and command-line options have been processed.
# Most non-user-configurable globals are also set here.
sub adjust_all_globals {
# Standardize $USER_DIR to never have trailing slash
$USER_DIR=~ s#/$## ;
# If no $LOCAL_HOST set, try to read it from first URL in list, or
# use the string 'localhost' if that URL contains no hostname.
unless (length($LOCAL_HOST)) {
$LOCAL_HOST= (&parse_url($ARGV[0]))[1] || 'localhost' ;
print STDERR "LOCAL_HOST set to \"\L$LOCAL_HOST\E\"\n" ;
}
$LOCAL_HOST= lc($LOCAL_HOST) ;
# If no $DOCUMENT_ROOT, try to guess it from $HOME, username, $USER_DIR.
unless (length($DOCUMENT_ROOT)) {
my($home) ;
unless ($home= $ENV{'HOME'}) {
my($uname)= getpwuid($<) || $ENV{'USER'} || `whoami` || `id -un` ;
chomp($uname) ;
&read_home_dirs unless %home_dir ; # only read when needed
$home= $home_dir{$uname} ;
}
$DOCUMENT_ROOT= "$home/$USER_DIR" ;
die "Could not determine DOCUMENT_ROOT; edit the $0 script to set it.\n"
unless (-d $DOCUMENT_ROOT) ;
print STDERR "DOCUMENT_ROOT set to \"$DOCUMENT_ROOT\"\n" ;
}
$DOCUMENT_ROOT=~ s#/$## ;
# Allows &filename_to_url() to unalias as best as possible. Note that
# use of &filename_to_url() can be avoided by the user; see note in
# that routine.
%UN_ALIAS= (reverse (%ALIAS, %SCRIPT_ALIAS) ) ;
# These are to compare equivalency to later, in &filename_to_url().
($DOC_ROOT_DEV, $DOC_ROOT_INODE)= stat("$DOCUMENT_ROOT/.") ;
$DOC_ROOT_EXISTS= -e _ ;
# Set CWD from shell variable, else from `pwd`.
$CWD= $ENV{'PWD'} || `pwd` || die "couldn't run pwd: $!" ;
chomp($CWD) ;
# These are used by &extract_urls().
# This is a complete list of URL-type attributes defined in HTML 4.0,
# plus any others I found, like nonstandard ones or from an earlier HTML.
# Only a few of these are commonly used, as of early 1998.
# The set in %html_urls could possibly link to HTML resources, while the
# set in %non_html_urls could not. The %special(.*) sets, here for
# reference only, include URL attributes that require special handling.
%html_urls= ( 'a' => [ 'href' ],
'area' => [ 'href' ],
'frame' => [ 'src', 'longdesc' ],
'link' => [ 'href', 'urn' ],
'img' => [ 'longdesc', 'usemap' ],
'q' => [ 'cite' ],
'blockquote' => [ 'cite' ],
'ins' => [ 'cite' ],
'del' => [ 'cite' ],
'object' => [ 'usemap' ],
'input' => [ 'usemap' ],
'iframe' => [ 'src', 'longdesc' ],
'ilayer' => [ 'src' ],
'layer' => [ 'src' ],
'fig' => [ 'imagemap' ],
'overlay' => [ 'imagemap' ],
'meta' => [ 'url' ],
'note' => [ 'src' ],
) ;
%non_html_urls= ( 'body' => [ 'background' ],
'img' => [ 'src', 'lowsrc', 'dynsrc' ],
'input' => [ 'src' ],
'script' => [ 'src', 'for' ],
'fig' => [ 'src' ],
'overlay' => [ 'src' ],
'select' => [ 'src' ],
'ul' => [ 'src' ],
'h1' => [ 'src' ],
'h2' => [ 'src' ],
'h3' => [ 'src' ],
'h4' => [ 'src' ],
'h5' => [ 'src' ],
'h6' => [ 'src' ],
'hr' => [ 'src' ],
'table' => [ 'src' ],
'td' => [ 'src' ],
'th' => [ 'src' ],
'tr' => [ 'src' ],
'bgsound' => [ 'src' ],
'embed' => [ 'src' ],
) ;
# %special_urls= ( 'base' => [ 'href' ] ) ;
#
# %special_html_urls= ( 'object' => [ 'codebase', 'data' ] ) ;
#
# %special_non_html_urls=
# ( 'head' => [ 'profile' ],
# 'object' => [ 'codebase', 'archive', 'classid' ],
# 'applet' => [ 'codebase', 'code', 'object', 'archive' ],
# 'form' => [ 'action', 'script' ]
# ) ;
# This is a translation from entity character references to characters,
# used in &HTMLunescape().
# This simplified version only supports " < > &, but that
# should be enough for URL-type attributes.
# See http://www.w3.org/TR/REC-html40/sgml/entities.html for full entity
# list.
%e_to_ch= (quot => '"',
'lt' => '<',
'gt' => '>',
amp => '&') ;
}
#----------------------------------------------------------------------
# Add the URL to our data structures; specifically, to %url and @urlstoget.
# Returns a pointer to the structure in %url, or undef if already defined
# or on error.
# Currently, this always receives the URL with the host name lowercase,
# either from &absolute_url() or from using $LOCAL_HOST.
sub add_url {
my($URL, $referer, $depth, $ishtml, $iscgi, $dontfollow)= @_ ;
# Allow the user to restrict URL patterns: URLs must be in
# @INCLUDE_PATTERNS but not in @EXCLUDE_PATTERNS (but only restrict
# by @INCLUDE_PATTERNS if it's not empty).
return undef if @INCLUDE_PATTERNS &&
!grep( $URL=~ /$_/, @INCLUDE_PATTERNS ) ;
return undef if grep( $URL=~ /$_/, @EXCLUDE_PATTERNS ) ;
# Canonicalize URL, so we don't get a page multiple times
$URL= &canonicalize($URL) ;
# for obscure case involving a <form action=___.cgi>-extracted URL being
# overwritten by <a href=___.cgi> extraction (don't fret over this)
$url{$URL}{'dontfollow'}&&= $dontfollow if $url{$URL} ;
# Don't add the record a second time! Or will infinitely traverse.
return undef if $url{$URL} ; # or add to @referers, for 301 correction...?
# Only HTTP URLs are currently supported
return undef unless $URL=~ /^http:/i ;
# Any self-referral here indicates a bug in the program. It's happened.
die "PROGRAM ERROR: $URL shows its first referer as itself.\n"
if $referer eq $URL ;
my(%u) ;
@u{qw(URL referer depth ishtml iscgi dontfollow)}=
($URL, $referer, $depth, $ishtml, $iscgi, $dontfollow) ;
$u{'islocal'}= ($URL=~ m#^http://\Q$LOCAL_HOST\E/#io) + 0 ; # make length>0
if ($u{'islocal'}) {
# $u{'filename'}= &url_to_filename($URL) ;
@u{'filename', 'location'}= &url_to_filename($URL) ;
$u{'iscgi'}= &is_cgi($u{'filename'}, $URL) if $u{'iscgi'} eq '' ;
# 2-27-00 JSM: Detect ishtml by filename, not -T test.
if ( $u{'ishtml'} eq '' ) {
$u{'ishtml'}= $HTML_BY_NAME
? ( !$u{'iscgi'} && -e $u{'filename'} &&
$u{'filename'}=~ /\.html?$/i ) + 0
: (!$u{'iscgi'} && -e $u{'filename'} && -T _) + 0 ;
}
# $u{'ishtml'}= (!$u{'iscgi'} && -e $u{'filename'} && -T _) + 0
# unless length($u{'ishtml'}) ;
}
# If we're only doing a file check, don't add URLs that require HTTP
return undef if ($file_check and (!$u{'islocal'} or $u{'iscgi'}) ) ;
push(@urlstoget, \%u) ;
$url{$URL}= \%u ;
# return \%u ; # unneeded because of previous statement
}
# Guess if a file is a CGI script or not. Returns true if the (regular) file
# is executable, has one of @CGI_EXTENSIONS, or if the URL is in a
# ScriptAlias'ed directory.
# $fname must be absolute path, but $URL is optional (saves time if available).
# Note that URLs like "/path/script.cgi?a=b" are handled correctly-- the
# previously extracted filename is tested for CGI-ness, while the URL is
# checked for ScriptAlias matching (which is unaffected by final query
# strings or PATH_INFO).
sub is_cgi {
my($fname, $URL)= @_ ;
return 1 if (-x $fname && ! -d _ ) ; # should we really do this?
foreach (@CGI_EXTENSIONS) { return 1 if $fname=~ /\Q$_\E$/i }
$URL= &filename_to_url($fname) unless length($URL) ; # currently unused
my($URLpath)= $URL=~ m#^http://[^/]*(.*)#i ;
foreach (keys %SCRIPT_ALIAS) { return 1 if $URLpath=~ /^\Q$_\E/ }
foreach (keys %SCRIPT_ALIAS_MATCH) { return 1 if $URLpath=~ /^$_/ }
return 0 ;
}
# Put the URL in such a form that two URLs that point to the same resource
# have the same URL, to avoid superfluous retrievals.
# Host name is lowercased elsewhere-- this routine is only called from
# &add_url; see note there. To lowercase the host name here would be
# inefficient.
sub canonicalize {
my($URL)= @_ ;
$URL=~ s/#.*// ; # remove any "#" fragment from end of URL
return $URL ;
}
#----- File reading/downloading routines (includes networking) --------
# Verify that a URL exists, and set $url->{'status'} accordingly. Do
# this either by checking the local filesystem or by using the HTTP HEAD
# method for remote sites or CGI scripts.
# Set $url->{'ishtml'} accordingly if discovered from Content-Type:.
# This does not support various Redirect directives in srm.conf.
sub verify_url {
my($url)= @_ ;
print STDERR "verifying $url->{'URL'}\n" if $debug ;
# Depending on the state of $url->{islocal, iscgi, dontfollow} and
# $full_http_check, take appropriate actions to check/set the
# status code for this URL.
# NOTE: In some situations, specifically when checking a CGI script
# named in a <form action> (thus implying that dontfollow is set),
# and using HTTP to check the URL (because the script is remote or
# $full_http_check is set), the HTTP response code may not be
# accurate. This is because there is no form data sent with the
# request, as there normally would be. In these cases, a cautionary
# note is appended to $url->{'status'}. Additionally, an empty
# $url->{'status'} is changed to an explanatory note (maybe we should
# do that in load_url() too?).
# Use HEAD if file is remote, or if $full_http_check is set.
if (!$url->{'islocal'} or $full_http_check) {
&load_url_using_HTTP($url, 'HEAD') ;
$url->{'status'}= '[no status returned]'
unless length($url->{'status'}) ;
$url->{'status'}.= ' (NOTE: Form was not submitted normally)'
if $url->{'dontfollow'} ;
# URL is local: If it's not CGI, do a normal local file check
} elsif (!$url->{'iscgi'}) {
$url->{'status'}= (-e $url->{'filename'})
? "200 Local File Exists" : "404 File Not Found" ;
# URL is local CGI: Use HEAD unless dontfollow is set
} elsif (!$url->{'dontfollow'}) {
&load_url_using_HTTP($url, 'HEAD') ;
# Else it's a local CGI with dontfollow set: Check for executable file
} else {
$url->{'status'}=
(! -e $url->{'filename'}) ? "404 File Not Found"
: (! -x $url->{'filename'}) ? "403 Local File Is Not Executable"
: "200 Local Executable File Exists"
}
# Old verify routine below:
#
# # If is a local non-CGI file, check it directly from the filesystem
# if ($url->{'islocal'} and !$url->{'iscgi'} and !$full_http_check) {
# $url->{'status'}= (-e $url->{'filename'})
# ? "200 Local File Exists" : "404 File Not Found" ;
#
# # Otherwise, download its HEAD from its HTTP server
# } else {
# &load_url_using_HTTP($url, 'HEAD') ;
# }
}
# Load entire file/resource and return its contents, setting $url->{'status'}
# accordingly. Do this either by checking the local filesystem or by
# using the HTTP GET method for remote sites or CGI scripts.
# Set $url->{'ishtml'} accordingly if discovered from Content-Type:.
# This does not support various Redirect directives in srm.conf.
sub load_url {
my($url)= @_ ;
my($HTML) ;
print STDERR "loading $url->{'URL'}\n" if $debug ;
# If is a local non-CGI file, read it directly from the filesystem
if ($url->{'islocal'} and !$url->{'iscgi'} and !$full_http_check) {
my($iscgi) ;
($HTML, $url->{'ssierrs'}, $iscgi)=
&read_expanded_file($url->{'filename'}, $url->{'URL'}) ;
$url->{'status'}=
!defined($HTML)
? sprintf("450 Can't read file: %s (%s)", $!, $!+0)
: @{$url->{'ssierrs'}}
? sprintf("451 SSI Error(s) (%s total)",
scalar @{$url->{'ssierrs'}})
: "200 Local File Read OK" ;
# $url->{'iscgi'} may be set if an SHTML file included CGI calls.
# Don't set it if we're doing a file check, in which case we'll
# keep whatever $HTML we could get.
$url->{'iscgi'}= $iscgi unless $file_check ;
}
# Otherwise (or if rereckoned), download the resource from its HTTP server
if (!$url->{'islocal'} or $url->{'iscgi'} or $full_http_check) {
(undef, undef, $HTML)= &load_url_using_HTTP($url, 'GET') ;
}
# Note that this will be set even when URL is to be reloaded, like
# for a 601 (timeout) response.
$url->{'hasbeenloaded'}= 1 ;
return $HTML ;
}
# Read a local file and return its contents. If a file is SSI (aka SHTML),
# expand any SSI <!--#include--> directives as needed, recursively
# including nested files.
# This is used for all local reads, SHTML or not, but the vast bulk of this
# routine is for SHTML files.
#
# If file is SHTML, this routine also returns a structure of error data,
# and a boolean saying if this file needs to be downloaded via HTTP
# for a complete check (e.g. includes CGI calls).
#
# $fname must be canonicalized absolute path, but $URL parameter is optional.
# %$parents contains all "include"-ancestors of the file, to prevent loops.
# If omitted, assumes no ancestors (and a fresh hash is started).
#
# This routine seems much bigger and more complex than it needs to be.
# It could be one third the size and much simpler if we didn't have to
# worry about full error reporting on nested includes.
#
# Note: This routine was made to mimic what Apache would return to a client.
# However, the result differs from Apache's in two slight ways, both
# involving nested SSI within <!--#include file="..." -->, and both
# apparent bugs in Apache 1.1 (may be fixed in later versions):
#
# 1) If a <file="..."> value contains no "/" (i.e. in current directory),
# then Apache always parses the included file as SHTML, regardless of
# extension. This routine checks @SHTML_EXTENSIONS for all included
# files.
# 2) If a <file="..."> value containing a "/" loads an SHTML file
# containing a <virtual="..."> tag with a relative path, the directive
# fails in Apache. This routine tries to guess the correct path/URL.
#
#
# Notes on this routine, and SHTML files in general:
#
# At first thought, it seems like we could load each included file
# only once, instead of once for every file that includes it.
# However, because of the fact that relative URLs are resolved
# relative to the top-level including file, the top-level file will
# need to be expanded every time. (It's legal (though of questionable
# wisdom) to include a file from e.g. both /a/index.shtml and
# /b/index.shtml, so links from the included file point to different
# URLs.)
#
# Note that while URLs in included files (e.g. <a href="...">) are
# resolved relative to the top-level including file, nested include tags
# are resolved relative to the direct includer.
#
# We could possibly be more efficient in time (but costly in memory)
# by storing the expanded contents and $errlist of each included file,
# since those will be constant (except $errlist's include-loop
# reporting might vary somewhat). There are probably other ways to
# eek out savings of time and memory, at the cost of complexity.
#
# The main loop here is inside of an s/// statement. Unusual, but it's an
# appropriate way to handle the recursion. Recursion is needed, since each
# included file may or may not be SHTML.
#
# $iscgi is set if a file includes "<!--#exec", or if it contains an
# <!--#include virtual="..." --> tag that points to a CGI file, or if
# any of its include-children sets $iscgi.
#
#
# Notes to help clarify data structures, if (God forbid) you have to modify
# this routine:
#
# Each error is a list of files in an "include chain", and $errlist is a
# list of errors. $errlist is associated with the current $HTML. Each
# error in $errlist is associated with some tag in $HTML, as iterated in
# the s/// loop. When this routine returns ($HTML, $errlist), the
# errors in $errlist should all have as their first element tags that
# were found in $HTML.
#
# Each error's final element (the "leaf") is associated with a tag that
# tried to load an invalid file. Each leaf will always be the complete
# set of errors for that tag (i.e. it has no children, since it couldn't
# load the file).
#
# If the file can be validly loaded, then we may have 0 or multiple errors
# associated with this file/tag (and returned from this routine). Each
# file's $errlist is an accumulation of all of its children's $errlist's.
#
# Errors that come from loading a child are associated with the child's
# $HTML and tags. Before adding them to the parent's (current) $errlist,
# they must have the CHILD's path/tag unshifted onto the front of the
# include chain; all errors are then added to the current $errlist.
# This ensures that:
# a) The errors are now all associated with the tag that loaded the child.
# b) The errors in the current $errlist are always associated with tags
# from the current $HTML.
#
sub read_expanded_file {
my($fname, $URL, $parents)= @_ ;
my($HTML, $errlist, $iscgi) ;
my($isshtml) ;
$parents->{$fname}= 1 ;
$HTML= &read_file($fname) ;
return(undef) unless defined($HTML) ;
foreach (@SHTML_EXTENSIONS) {
$isshtml= 1, last if ($fname=~ /\Q$_\E$/i) ;
}
if ($isshtml) {
$errlist= [] ;
$iscgi= ($HTML=~ /<!--#exec\b/i) ;
$HTML=~ s{(<!--#include\b.*?>)} {
do {
my($childfname, $childURL) ;
my($childHTML, $childerrlist, $childiscgi) ;
my($tagst) = $1 ;
my($tag)= &parse_tag($tagst) ;
GET_CHILD: {
if (length($tag->{'attrib'}{'virtual'})) {
$URL= &filename_to_url($fname) unless length($URL) ;
$childURL=
&absolute_url($tag->{'attrib'}{'virtual'}, $URL) ;
($childfname)= &url_to_filename($childURL) ;
# If it's a CGI, don't follow it, but no error either
if (&is_cgi($childfname, $childURL)) {
$iscgi= 1 ;
last GET_CHILD ;
}
} elsif (length($tag->{'attrib'}{'file'})) {
$childfname= $tag->{'attrib'}{'file'} ;
if ($childfname=~ m#^(/|~)#) {
push(@$errlist, [ {'path' => $childfname,
'tag' => $tagst, 'errmsg' =>
'Absolute paths are not allowed in '
. '<!--#include file="..." -->.'}]);
last GET_CHILD ;
}
if ($childfname=~ m#\.\.(/|$)#) {
push(@$errlist, [ {'path' => $childfname,
'tag' => $tagst, 'errmsg' =>
'Paths can not contain "../" in '
. '<!--#include file="..." -->.'}]);
last GET_CHILD ;
}
$childfname= ($fname=~ m#(.*/)#)[0] . $childfname ;
} else {
push(@$errlist, [ {'path' => '',
'tag' => $tagst, 'errmsg' =>
'Tag must contain either the "file" or '
. '"virtual" attribute.'}]);
last GET_CHILD ;
}
# canonicalize filename for %$parents
1 while $childfname=~ s#/\.(/|$)#/# ;
1 while $childfname=~ s#/(?!\.\./)[^/]+/\.\.(/|$)#/# ;
# Guarantee that file exists, is regular, and is readable
unless (-e $childfname) {
push(@$errlist, [{'path' => $childfname, 'tag' => $tagst,
'errmsg' => 'File not found'} ] ) ;
last GET_CHILD ;
}
unless (-f $childfname) {
push(@$errlist, [{'path' => $childfname, 'tag' => $tagst,
'errmsg' => 'File is not a regular'
. ' file.' } ] ) ;
last GET_CHILD ;
}
unless (-r $childfname) {
push(@$errlist, [{'path' => $childfname, 'tag' => $tagst,
'errmsg' => 'File is not readable by'
. ' current user.' } ] ) ;
last GET_CHILD ;
}
# Guard against include loops
if ($parents->{$childfname}) {
push(@$errlist, [{'path' => $childfname, 'tag' => $tagst,
'errmsg' => 'An "include" loop exists'
. ' involving this file.' } ] ) ;
last GET_CHILD ;
}
# Get the included file, with any error data
($childHTML, $childerrlist, $childiscgi)=
&read_expanded_file($childfname, $childURL, $parents) ;
# Log if there was any error reading the file
push(@$errlist, [{'path' => $childfname, 'tag' => $tagst,
'errmsg' => "Can't read file: $!." } ] )
unless defined($childHTML) ;
# Add any errors to the current (parent) error list
foreach my $error (@$childerrlist) {
unshift(@$error,
{ 'path' => $childfname, 'tag' => $tagst } ) ;
}
push(@$errlist, @$childerrlist) ;
# Parent is a CGI if any of its children is a CGI
$iscgi||= $childiscgi ;
} # GET_CHILD
$childHTML ; # final value to replace in main s/// construct
} # do {}
}gie ; # $HTML=~ s{} {}
} # if ($isshtml)
delete $parents->{$fname} ;
return($HTML, $errlist, $iscgi) ;
}
# Returns the contents of the named file, or undef on error.
sub read_file {
my($fname)= @_ ;
local(*F, $/) ;
undef $/ ;
open(F, "<$fname") || return undef ;
my($ret)= <F> ;
close(F) ;
return $ret ;
}
# Try to get the given URL with the given HTTP method, and return the
# status line, headers, and body.
# Set $url->{'status'} accordingly, and set $url->{'ishtml'} accordingly
# if Content-Type: header is returned.
# This is specific to this program, and calls the more general &get_url().
# This could be slightly more efficient if 302 or 303 was handled in the
# calling routine, where it could take advantage of a new URL being local.
sub load_url_using_HTTP {
my($url, $method)= @_ ;
my($status_line, $headers, $body) ;
# We should not get here if $file_check is set
die "mistakenly called load_url_using_HTTP($url->{'URL'})" if $file_check ;
GETFILE: {
($status_line, $headers, $body)=
&get_url( ($url->{'location'} || $url->{'URL'}), $method) ;
# If HEAD failed (as on some servers), sigh and use GET
($status_line, $headers, $body)=
&get_url( ($url->{'location'} || $url->{'URL'}), 'GET')
unless length($status_line) ;
($url->{'status'})= $status_line=~ m#^HTTP/[\d.]+\s+(.*)# ;
# 2-27-00 JSM: Allow old NCSA servers to not include the HTTP version.
if ($SUPPORT_NCSA_BUG and $url->{'status'} eq '') {
($url->{'status'})= $status_line=~ m#^HTTP(?:/[\d.]+)?\s+(.*)# ;
}
# Redirect to new location if status is 302 or 303
if ($url->{'status'}=~ /^(301|302|303)\b/) {
($url->{'location'})= $headers=~ m#^Location:[ \t]+(\S+)#im ;
last GETFILE unless length($url->{'location'}) ;
$url->{'location'}=
&absolute_url($url->{'location'}, $url->{'URL'}) ;
redo GETFILE
if ($url->{'status'}=~ /^(302|303)\b/)
&& (++$url->{'numredirects'} <= $MAX_REDIRECTS) ;
}
}
$url->{'numtries'}++ ;
$url->{'lasttried'}= time ;
# If successful response included Content-Type:, set ishtml accordingly
$url->{'ishtml'}= (lc($1) eq 'text/html') + 0
if $url->{'status'}=~ /^2/
and $headers=~ m#^content-type:[ \t]*(\S+)#im ;
print STDERR "status: $status_line\n" if $debug ;
return($status_line, $headers, $body) ;
}
# Request the HTTP resource at the given absolute URL using the given method,
# and return the response status line, headers, and body.
# jsm-- in the future, this should support downloading to a file, in case
# the download is too large to fit in memory.
sub get_url {
my($URL, $method)= @_ ;
my($host, $uri, $endhost) ;
my($S, $rin) ;
my($response, $status_line, $headers, $body, $status_code) ;
my($content_length) ;
$method= uc($method) ;
$method= 'GET' unless length($method) ;
($host, $uri)= $URL=~ m#^http://([^/]*)(.*)$#i ;
$uri= '/' unless length($uri) ;
$endhost= $host ;
# use an HTTP proxy if $ENV{'http_proxy'} is set
USEPROXY: {
last USEPROXY unless $host=~ /\./ ;
if (length($ENV{'http_proxy'})) {
foreach (@NO_PROXY) {
last USEPROXY if $host=~ /$_$/i ;
}
($host)= $ENV{'http_proxy'}=~ m#^(?:http://)?([^/]*)#i ;
$uri= $URL ;
}
}
# Open socket
$S= IO::Socket::INET->new(PeerAddr => $host, # may contain :port
PeerPort => 80, # default if none in PeerAddr
Proto => 'tcp') ;
return("HTTP/1.1 600 Can't create socket: $@") unless defined($S) ;
$S->autoflush() ; # very important!!
# Send HTTP 1.1 request
print $S "$method $uri HTTP/1.1\015\012",
"Host: $endhost\015\012",
"Connection: close\015\012",
"User-agent: CheckLinks/$CL_VERSION\015\012",
"\015\012" ;
# Wait for socket response with select()
vec($rin= '', fileno($S), 1)= 1 ;
select($rin, undef, undef, 60)
|| return("HTTP/1.1 601 Connection timed out") ;
local($/)= "\012" ;
# Handle "100 Continue" responses for HTTP 1.1: loop until non-1xx.
do {
$status_line= <$S> ;
$status_line=~ s/\015?\012$// ;
($status_code)= $status_line=~ m#^HTTP/\d+\.\d+\s+(\d+)# ;
$headers= '' ;
while (<$S>) {
last if /^\015?\012/ ;
$headers.= $_ ;
}
$headers=~ s/\015?\012[ \t]+/ /g ;
} until $status_code!~ /^1/ ;
# Body length is determined by HTTP 1.1 spec, section 4.4: these
# certain conditions implying no body, then chunked encoding,
# then Content-length: header, then server closing connection.
if ($method eq 'HEAD' or $status_code=~ /^(1|204\b|304\b)/) {
$body= undef ;
# else chunked encoding
} elsif ($headers=~ /^transfer-encoding:[ \t]*chunked\b/im) {
# 7-16-99: Old code was only saving last chunk. Fix using
# $this_chunk contributed by Mark Trotter.
my($this_chunk, $chunk_size, $readsofar, $thisread) ;
while ($chunk_size= hex(<$S>)) {
$readsofar= 0 ;
while ($readsofar!=$chunk_size) {
last unless $thisread=
read($S, $this_chunk, $chunk_size-$readsofar, $readsofar) ;
$readsofar+= $thisread ;
}
return("HTTP/1.1 603 Incomplete chunked response", $headers, $body)
if $readsofar!=$chunk_size ;
$_= <$S> ; # clear CRLF after chunk
$body.= $this_chunk ;
}
# Read footers if they exist
while (<$S>) {
last if /^\015?\012/ ;
$headers.= $_ ;
}
$headers=~ s/\015?\012[ \t]+/ /g ;
# else body length given in Content-length:
} elsif (($content_length)= $headers=~ /^content-length:[ \t]*(\d+)/im) {
my($readsofar, $thisread) ;
while ($readsofar!=$content_length) {
last unless $thisread=
read($S, $body, $content_length-$readsofar, $readsofar) ;
$readsofar+= $thisread ;
}
return(sprintf("HTTP/1.1 602 Incomplete response (%s of %s bytes)",
$readsofar+0, $content_length),
$headers, $body)
if $readsofar!=$content_length ;
# else body is entire socket output
} else {
local($/)= undef ;
$body= <$S> ;
}
close($S) ;
return($status_line, $headers, $body) ;
}
#----- URL-parsing routines -------------------------------------------
# The routines parse_url(), unparse_url(), and absolute_url() are based on
# different sections in the Internet Draft "Uniform Resource Identifiers
# (URI): Generic Syntax and Semantics", 11-18-97, by Berners-Lee,
# Fielding, and Masinter, filename draft-fielding-uri-syntax-01.
# Parse a URL into its components, according to URI draft, sections 4.3, 4.4.
# This regular expression is straight from Appendix B, modified to use Perl 5.
# Returns scheme, site, path, query, and fragment. All but path may have
# the undefined value.
sub parse_url {
my($URL)= @_ ;
my($scheme, $site, $path, $query, $fragment)=
($URL=~ m{^(?: ([^:/?\#]+):)?
(?: // ([^/?\#]*))?
([^?\#]*)
(?: \? ([^\#]*))?
(?: \# (.*))?
}x
) ;
# Un-URL-encode the path, to equivalate things like %7E --> ~
# Note that in some situations, this may cause problems with URLs that
# contain the % character: if the unescaped URL is then used in
# relative URL calculation, it may be unescaped again (rare).
$path=~ s/\+/ /g ;
$path=~ s/%([0-9A-Fa-f]{2})/chr(hex($1))/ge ;
# Note that in HTTP, the presence of a host implies a path beginning with
# '/', so $path should be '/' for URLs like "http://www.somehost.com"
$path= '/' if !length($path) && length($site) && lc($scheme) eq 'http' ;
return($scheme, $site, $path, $query, $fragment) ;
}
# Returns a full URL string, given its components
# The full procedure is described in the URI draft, section 5.2, step 7.
sub unparse_url {
my($scheme, $site, $path, $query, $fragment)= @_ ;
my($URL) ;
$URL= "$scheme:" if defined($scheme) ;
$URL.= "//$site" if defined($site) ;
$URL.= $path ;
$URL.= "?$query" if defined($query) ;
$URL.= "#$fragment" if defined($fragment) ;
return $URL ;
}
# Returns a canonicalized absolute URL, given a relative URL and a base URL.
# The full procedure is described in the URI draft, section 5.2.
# Note that a relative URI of "#fragment" should be resolved to "the current
# document", not to an absolute URL. This presents a quandary for this
# routine: should it always return an absolute URL, thus violating the
# spec, or should it not always return an absolute URL, thus requiring any
# caller to check for this special case? This routine leaves that up to
# the caller, with $return_rel_fragment-- if set, stick to the spec;
# otherwise, always return an absolute URL. See section G.4 of the draft.
# Note that the pathname reduction in steps 6.c-f messes up any PATH_INFO
# that has ./ or ../ in it, which may be a bug in the spec.
sub absolute_url {
my($relurl, $baseurl, $return_rel_fragment)= @_ ;
my(@relurl, @baseurl) ;
# parse_url() returns scheme, site, path, query, fragment
@relurl= &parse_url($relurl) ; # Step 1
@baseurl= &parse_url($baseurl) ;
COMBINE: {
# Step 2
# See note above about $return_rel_fragment
if ( $relurl[2] eq '' &&
!defined($relurl[0]) &&
!defined($relurl[1]) &&
!defined($relurl[3]) ) {
@relurl[0..3]= @baseurl[0..3] ;
return $relurl if $return_rel_fragment ; # see note above
last COMBINE ;
}
last COMBINE if defined($relurl[0]) ; # Step 3
$relurl[0]= $baseurl[0] ;
last COMBINE if defined($relurl[1]) ; # Step 4
$relurl[1]= $baseurl[1] ;
last COMBINE if $relurl[2]=~ m#^/# ; # Step 5
# Step 6-- resolve relative path
my($path)= $baseurl[2]=~ m#^(.*/)# ; # Step 6.a
$relurl[2]= $path . $relurl[2] ; # Step 6.b
} # COMBINE
# Put the remaining steps outside of the block to canonicalize the path.
# Arguably, this is not allowed. To avoid such arguments at the expense of
# path canonicalization, put steps 6.c-f back in the COMBINE block.
1 while $relurl[2]=~ s#(^|/)\./#$1# ; # Step 6.c
$relurl[2]=~ s#(^|/)\.$#$1# ; # Step 6.d
# Step 6.e
my($oldpath) ;
while ($relurl[2]=~ s#(([^/]+)/\.\./)# ($2 eq '..') ? $1 : '' #ge) {
last if ($relurl[2] eq $oldpath) ;
$oldpath= $relurl[2] ;
}
# Step 6.f
$relurl[2]=~ s#(([^/]+)/\.\.$)# ($2 eq '..') ? $1 : '' #ge ;
# Step 6.g: allow leading ".." segments to remain in path
# Step 6.h: relurl[2] is already the buffer string
# To canonicalize further, lowercase the hostname (is this valid for all
# schemes?)
$relurl[1]= lc($relurl[1]) if defined($relurl[1]) ;
return &unparse_url(@relurl) ; # Step 7
}
# Convert a local URL into a canonicalized absolute path, or undef if
# not on this host or other error.
# Result should only be used as filename.
# Supports UserDir (e.g. public_html) for "/~username/path/file" URLs.
# Supports Alias, AliasMatch, ScriptAlias, and ScriptAliasMatch from srm.conf
# (but note use of Perl regex's instead of standard regex's).
# Inserts index.html, etc. (from @DIRECTORY_INDEX) if result is a directory,
# but just return directory name (ending in '/') if none of those exists.
# Removes PATH_INFO, if any, from filename.
# Directory names are always returned with trailing slash (which would not
# be appropriate if PATH_INFO was to be retained).
# While this routines makes some tests (e.g. if the file is a directory),
# it does not verify that file at the resulting $filename exists.
# Note that not all URLs point to files, so this routine is not always
# appropriate. In this program, the result from this routine is only
# used when we know the URL is not a CGI script (and is therefore a file),
# except in &is_cgi() itself, which tests if a file is a CGI script.
# If it weren't for &is_cgi(), we could ignore cases when the URL isn't
# a file.
# 12-1-99 JSM: Changed to also return "redirected" location, in case URL
# is a directory but not ending in a slash, so relative URLs will resolve
# correctly against the redirected URL.
sub url_to_filename {
my($URL)= @_ ;
my($URLpath, $path, $location, $docroot, $user) ;
return undef unless $URL=~ m#^http://\Q$LOCAL_HOST\E/#io ;
$URLpath= (&parse_url($URL))[2] ;
die "couldn't get path from [$URL]" unless length($URLpath) ;
# Note minor security hole: if this script is run setuid, then any
# file on the system could be read by using an ALIAS to point to the
# file. Note also that if a $URLpath such as "/alias/dir/../.." is
# passed to this routine, the alias will be substituted BEFORE the
# ".." path segments are traversed. A case like this probably a
# mistake in the URL anyway.
# Make no more than one alias substitution-- is there a precedence order?
# Note that %(.*)_MATCH use Perl regex's, not standard regex's.
# 3-29-99 JSM: These all alias to actual directory, not to a resulting
# URL, so no further conversion should be done if one of these matches.
# 3-29-99 JSM: Changed ALIAS_MATCH and SCRIPT_ALIAS_MATCH blocks to
# allow $1-type substitution in targets; MUST TEST!
ALIAS: {
foreach (keys %ALIAS)
{ $path= $URLpath, last ALIAS
if $URLpath=~ s/^\Q$_\E/$ALIAS{$_}/ }
foreach (keys %ALIAS_MATCH)
{ $path= $URLpath, last ALIAS
if eval "\$URLpath=~ s/^\$_/$ALIAS_MATCH{$_}/" }
foreach (keys %SCRIPT_ALIAS)
{ $path= $URLpath, last ALIAS
if $URLpath=~ s/^\Q$_\E/$SCRIPT_ALIAS{$_}/ }
foreach (keys %SCRIPT_ALIAS_MATCH)
{ $path= $URLpath, last ALIAS
if eval "\$URLpath=~ s/^\$_/$SCRIPT_ALIAS_MATCH{$_}/" }
}
# If $path has been set in above ALIAS block, no further conversion is
# needed.
if ($path eq '') {
# Must check for ^/.. before PATH_INFO check, in case $URL's path
# is e.g. '/../conf/access.conf'
return undef if $URLpath=~ m#^/\.\.(/|$)# ; # ^/.. is not allowed
# Set $docroot and $path for this file, based on the URL (contains '~' ?)
if (length($USER_DIR) and ($user,$path)= $URLpath=~ m#^/~([^/]+)(.*)# ) {
&read_home_dirs unless %home_dir ; # only read when needed
return undef unless length($home_dir{$user}) ;
$docroot= "$home_dir{$user}/$USER_DIR" ;
$path= '/' unless length($path) ;
} else {
# If we have no $DOCUMENT_ROOT, we can't handle URLs without ~.
return undef unless $DOC_ROOT_EXISTS ;
$docroot= $DOCUMENT_ROOT ;
$path= $URLpath ;
}
# Handle PATH_INFO: remove path segments until an existing file is named.
# Note that directories cannot have PATH_INFO after them.
unless (-e "$docroot$path") {
for (my($path2)= $path ; $path2=~ m#/# ; $path2=~ s#/[^/]*$##) {
last if -d "$docroot$path2" ;
$path= $path2, last if -e "$docroot$path2" ;
}
}
# canonicalize path, and recheck for ^/.. (handles an obscure error,
# when $URL's path is e.g. '/a/b/../../..'; but must canonicalize
# after PATH_INFO check, in case path is e.g. '/a/b.cgi/../../..').
1 while $path=~ s#/\.(/|$)#/# ;
1 while $path=~ s#/(?!\.\./)[^/]+/\.\.(/|$)#/# ;
return undef if $path=~ m#^/\.\.(/|$)# ; # ^/.. is not allowed
$path= "$docroot$path" ;
}
# Add "index.html", etc. if appropriate
if (-d $path) {
$path.= '/' unless $path=~ m#/$# ;
# 12-1-99 JSM: set "redirected" location also
$location= "$URL/" unless $URL=~ m#/$# ;
foreach (@DIRECTORY_INDEX) {
$path.= $_, last if -f "$path$_" ;
}
}
return ($path, $location) ;
}
# Convert a local (possibly relative) pathname into a canonicalized URL.
# If filename is relative and no $basepath is given, assume it's in the
# current directory.
# Supports UserDir (e.g. public_html) for "/~username/path/file" URLs.
# Each path segment is checked to see if it's the same as $DOCUMENT_ROOT,
# by comparing inodes. When a match is found, it's cut off the front,
# and an absolute URL is constructed. If $DOCUMENT_ROOT is never matched,
# then $USER_DIR is scanned for. If that doesn't match (i.e. the file
# is not served to the Web), undef is returned.
# Note that $DOC_ROOT_DEV and $DOC_ROOT_INODE are set at the start of the
# program for efficiency, but are an integral part of this routine.
# %ALIAS is supported using %UN_ALIAS, as best as possible. See next note
# on avoiding use of this routine.
# This is currently only used when parsing command-line filenames, and when
# an <!--#include file="..." --> includes an <!--#include virtual="..." -->
# (which may be an error anyway). Thus, it can be avoided if needed, such
# as when complex aliasing makes results ambiguous.
# jsm-- should this add/remove @DIRECTORY_INDEX, to avoid some duplication?
# 3-29-99 JSM: Changed UNALIAS handling-- if it's unaliased, then no other
# conversion is necessary.
sub filename_to_url {
my($path, $basepath)= @_ ;
my($URLpath) ;
unless ($path=~ m#^/#) {
$basepath= $CWD unless length($basepath) ;
$basepath.= '/' if -d $basepath && $basepath!~ m#/$# ;
$basepath=~ s#/[^/]*$#/# ;
$path= "$basepath$path" ;
}
# canonicalize filename by removing ./ and ../ where appropriate
1 while $path=~ s#/\.(/|$)#/# ;
1 while $path=~ s#/(?!\.\./)[^/]+/\.\.(/|$)#/# ;
# canonicalize directory to include final /
$path.= '/' if -d $path && $path!~ m#/$# ;
# First, if path can be unaliased, return that.
# (Added 3-29-99 by JSM.)
foreach (keys %UN_ALIAS)
{ $URLpath= $path, last if $path=~ s/^\Q$_\E/$UN_ALIAS{$_}/ }
return "http://\L$LOCAL_HOST\E$URLpath" if $URLpath ne '' ;
# Then, check if file is under $DOCUMENT_ROOT tree, and convert if so.
if ($DOC_ROOT_EXISTS) {
my($doc_root)= $path ;
while ($doc_root=~ s#/[^/]*$##) {
my($dev,$inode)= stat("$doc_root/.") ;
if ( ($dev==$DOC_ROOT_DEV) && ($inode==$DOC_ROOT_INODE) ) {
$path=~ s/^$doc_root// ;
# foreach (keys %UN_ALIAS)
# { last if $path=~ s/^\Q$_\E/$UN_ALIAS{$_}/ }
return "http://\L$LOCAL_HOST\E$path" ;
}
}
}
# Handle possible case of "~username/$USER_DIR/$path"
# I don't think %ALIAS applies here, does it?
# This misses some when $HOME/$USER_DIR points through a symbolic link,
# and $CWD isn't set to match %dir_to_user. Work around by avoiding
# this routine, e.g. using only URLs on command line.
if (length($USER_DIR)) {
if ($path=~ m#^(.*?)/$USER_DIR(/.*)# ) {
# First, see if path is in %dir_to_user
&read_home_dirs unless %dir_to_user ; # only read when needed
return "http://\L$LOCAL_HOST\E/~$dir_to_user{$1}$2"
if length($dir_to_user{$1}) ;
# If not, then we must check inodes to equivalate directories
&read_inode_to_user unless %inode_to_user ; # only read when needed
my($dev,$inode)= stat("$1/.") ;
return "http://\L$LOCAL_HOST\E/~$inode_to_user{$dev}{$inode}$2"
if length($inode_to_user{$dev}{$inode}) ;
}
}
return undef ;
}
# Reads all users' home directory into %home_dir, from /etc/passwd.
# Also creates %dir_to_user, which is faster than %inode_to_user (below).
# Only used when $USER_DIR is used, for "/~username/path/file" URLs.
# 2-27-00 JSM: Changed to use getpwent, instead of reading /etc/passwd.
sub read_home_dirs {
my($user, $homedir) ;
setpwent ; # to rewind, in case getpwent has already been used
while ( ($user, $homedir)= (getpwent)[0,7] ) {
$home_dir{$user}= $homedir ;
$dir_to_user{$homedir}= $user
unless $dir_to_user{$homedir} ne '' ;
}
endpwent ; # clean way to end getpwent processing
}
# Reads home directory inode information into %inode_to_user, from /etc/passwd.
# Because this is time-consuming, it is only called if needed, and only once.
# Only used when $USER_DIR is used, for "/~username/path/file" URLs.
# On SPARCstation-10 with 3000 /etc/passwd records, this takes ~2 seconds.
# 2-27-00 JSM: Changed to use already-existing %home_dir, instead of reading
# /etc/passwd again.
sub read_inode_to_user {
my($user, $homedir) ;
my($dev, $inode) ;
&read_home_dirs unless %home_dir ; # only read when needed
while ( ($user, $homedir)= each %home_dir ) {
($dev,$inode)= stat("$homedir/.") ;
$inode_to_user{$dev}{$inode}= $user
unless $inode_to_user{$dev}{$inode} ne '' ;
}
}
#----- Extracting URLs from HTML ------------------------------------
# Parse an SGML tag, and return a hash structure with a "name" scalar and
# an "attrib" hash.
# Parses first tag in string, ignoring all surrounding text.
# Results are canonicalized to lower case wherever case-insensitive.
sub parse_tag {
my($tag)= @_ ; # will be mangled
my($tagname,%attrib) ;
# only parse first tag in string
($tag)= split(/>/, $tag) ; # remove all after >
$tag=~ s/^([^<]*<)?\s*// ; # remove pre-<, <, and leading blanks
($tagname,$tag)= split(/\s+/, $tag, 2) ; # split out tag name
# Extract name/value (possibly quoted), lowercase name, set $attrib{}.
# If quoted, is delimited by quotes; if not, delimited by whitespace.
$attrib{lc($1)}= &HTMLunescape($+)
while ($tag=~ s/\s*(\w+)\s*=\s*(([^"']\S*)|"([^"]*)"?|'([^']*)'?)//) ;
# now, get remaining non-valued (boolean) attributes
$tag=~ s/^\s*|\s*$//g ; # skip leading/trailing blanks
foreach (split(/\s+/, $tag)) {
$_= lc($_) ;
$attrib{$_}= $_ ; # booleans have values equal to their name
}
return { 'name' => lc($tagname),
'attrib' => \%attrib } ;
}
# Unescape any HTML character references and return resulting string.
# Support entity character references in %e_to_ch (which is incomplete),
# plus "$#ddd;" and "Ý" forms for values<256.
# Note that not decoding a valid character is erroneous, in that a
# subsequent re-escaping will not return the original string, because
# of the ampersand. Nonetheless, that's preferable to losing the data.
# Q: Is there an appropriate general way to represent an unescaped string?
sub HTMLunescape {
my($s)= @_ ;
# Try alpha, decimal, and hex representations, only substituting if valid
$s=~ s/&(([a-zA-Z][a-zA-Z0-9.-]*);?|#([0-9]+);?|#[Xx]([0-9a-fA-F]+);?)/
length($2) ? ( defined($e_to_ch{$2}) ? $e_to_ch{$2} : "&$1" )
: length($3) ? ( $3 < 256 ? chr($3) : "&$1" )
: length($4) ? ( hex($4) < 256 ? chr(hex($4)) : "&$1" )
: "&$1"
/ge ;
return $s ;
}
# Given a block of HTML, extracts all URLs referenced in it, and adds them
# to our data structures to be downloaded or checked (i.e. calls
# &add_url()).
# Note that %html_urls and %non_html_urls are set at the start of the
# program for efficiency, but are an integral part of this routine.
# Currently, this extracts all <.*?> patterns, which may not be valid if
# "<" or ">" characters are e.g. inside a <script> element.
sub extract_urls {
my($HTML, $baseurl, $referer, $depth)= @_ ;
my(@tags) ;
# Remove comments before extracting links, as pointed out by Tim Hunter.
$HTML=~ s/<!--.*?--.*?>//gs ;
# We must look for <base> tag before all the work, so we must parse
# all tags first. :( Therefore, we save this large array of
# structures for efficiency, hoping we don't run out of memory.
my($i)= -1 ; # to start at array element 0
foreach ($HTML=~ /(<.*?>)/gs) {
$tags[++$i]= &parse_tag($_) ;
$baseurl= $tags[$i]{'attrib'}{'href'}
if ($tags[$i]{'name'} eq 'base')
and (length($tags[$i]{'attrib'}{'href'})) ;
}
# For each tag, call &add_url() for each URL in the tag
foreach my $tag (@tags) {
next if $tag->{'name'}=~ m#^/# ;
# Handle the "regular" tag-attributes, in %html_urls and %non_html_urls
foreach (@{$html_urls{$tag->{'name'}}}) {
&add_url(&absolute_url($tag->{'attrib'}{$_}, $baseurl),
$referer, $depth)
if length($tag->{'attrib'}{$_}) ;
}
foreach (@{$non_html_urls{$tag->{'name'}}}) {
&add_url(&absolute_url($tag->{'attrib'}{$_}, $baseurl),
$referer, $depth, 0)
if length($tag->{'attrib'}{$_}) ;
}
# Now handle each tag-attribute that needs special attention
if ($tag->{'name'} eq 'object') {
my($codebase)=
&absolute_url($tag->{'attrib'}{'codebase'}, $baseurl) ;
&add_url(&absolute_url($tag->{'attrib'}{'data'}, $codebase),
$referer, $depth)
if length($tag->{'attrib'}{'data'}) ;
# There seems to be a contradiction between the HTML 4.0 spec
# section 13.3.3 and RFC 1808 section 4 step 2b regarding
# the URL resolution of e.g. classid="java:program.start".
# For now, we'll stick with the RFC 1808 method.
&add_url(&absolute_url($tag->{'attrib'}{'classid'}, $codebase),
$referer, $depth, 0)
if length($tag->{'attrib'}{'classid'}) ;
# <object> tag's "archive" attribute is a space-separated list
foreach (split(/\s+/, $tag->{'attrib'}{'archive'})) {
&add_url(&absolute_url($_, $codebase), $referer, $depth, 0) ;
}
} elsif ($tag->{'name'} eq 'head') {
# "profile" attribute is a space-separated list
foreach (split(/\s+/, $tag->{'attrib'}{'profile'})) {
&add_url(&absolute_url($_, $baseurl), $referer, $depth, 0) ;
}
} elsif ($tag->{'name'} eq 'applet') {
my($codebase)=
&absolute_url($tag->{'attrib'}{'codebase'}, $baseurl) ;
&add_url(&absolute_url($tag->{'attrib'}{'code'}, $codebase),
$referer, $depth, 0)
if length($tag->{'attrib'}{'code'}) ;
&add_url(&absolute_url($tag->{'attrib'}{'object'}, $codebase),
$referer, $depth, 0)
if length($tag->{'attrib'}{'object'}) ;
# <applet> tag's "archive" attribute is a comma-separated list
foreach (split(/\s*,\s*/, $tag->{'attrib'}{'archive'})) {
&add_url(&absolute_url($_, $codebase), $referer, $depth, 0) ;
}
# Check form script for existence only, but don't follow hyperlinks.
# Handles the unlikely case when a CGI is referred to by both a
# <form action=___.cgi> tag and an <a href=___.cgi> tag: If a CGI
# is only pointed to by <form action>, then don't follow the link
# (i.e. set $url->{'dontfollow'} to verify, not load). If a CGI
# is called by at least one <a href> tag, then do follow the link.
} elsif ($tag->{'name'} eq 'form') {
&add_url(&absolute_url($tag->{'attrib'}{'action'}, $baseurl),
$referer, $depth, undef, 1, 1)
if length($tag->{'attrib'}{'action'}) ;
} # if ($tag->{'name'} eq '...')
} # foreach $tag (@tags)
} # &extract_urls()
#----- output routines ------------------------------------------------
# Generate final report
sub make_report {
if ($verbose_report) { &make_verbose_report }
else { &make_short_report }
}
# Generate a verbose report of all URLs that have been checked
sub make_verbose_report {
my($rootlist)= join("\n ", @ARGV) ;
my($numurls)= scalar keys %url ;
print <<EOH ;
======================================================================
Report of invalid links on $LOCAL_HOST,
recursively followed starting with the files/URLs:
$rootlist
EOH
if (@INCLUDE_PATTERNS) {
my($includelist)= join("\n ", @INCLUDE_PATTERNS) ;
print <<EOH ;
Only including URLs matching at least one of the following patterns:
$includelist
EOH
}
if (@EXCLUDE_PATTERNS) {
my($excludelist)= join("\n ", @EXCLUDE_PATTERNS) ;
print <<EOH ;
Excluding URLs matching any of the following patterns:
$excludelist
EOH
}
print "Total URLs checked: $numurls\n\n" ;
print( "Only reporting response codes beginning with: ",
join(", ", @INCLUDE_STATUS), "\n" )
if @INCLUDE_STATUS ;
print( "Excluding response codes beginning with: ",
join(", ", @EXCLUDE_STATUS), "\n" )
if @EXCLUDE_STATUS ;
print "Maximum traversal depth: $max_depth\n" if length($max_depth) ;
print "Only local files were checked; no CGI scripts were invoked.\n"
if $file_check ;
print "Local URLs were read from the filesystem where possible.\n"
unless $full_http_check ;
print "\n" ;
# Only report status errors if there are any.
# Using grep()s is slightly inefficient, but a *lot* cleaner.
my($has_statuserrs) ;
foreach my $URL (sort keys %url) {
next if @INCLUDE_STATUS &&
!grep($url{$URL}{'status'}=~ /^$_/, @INCLUDE_STATUS) ;
next if grep($url{$URL}{'status'}=~ /^$_/, @EXCLUDE_STATUS) ;
$has_statuserrs=1, last ;
}
if ($has_statuserrs) {
print <<EOH ;
======================================================================
RESULTS FROM ALL URLS WITH SELECTED RESPONSE STATUS CODES
------------------------------------------------------------
EOH
foreach (sort keys %url) {
my($u)= $url{$_} ;
next if @INCLUDE_STATUS &&
!grep($u->{'status'}=~ /^$_/, @INCLUDE_STATUS) ;
next if grep($u->{'status'}=~ /^$_/, @EXCLUDE_STATUS) ;
print "$u->{'URL'}\n", '-' x 50, "\n" ;
print "Status: $u->{'status'}\n" ;
print "Moved to: $u->{'location'}\n" if $u->{'location'} ;
print "Depth: $u->{'depth'}\n" ;
for (my($URL)= $u->{'referer'}, my($tab)= ' ' ;
length($url{$URL}) ;
$URL= $url{$URL}{'referer'}, $tab.= ' ' )
{
print "${tab}referred by $url{$URL}{'URL'}\n" ;
die "PROGRAM ERROR: apparent infinite referer loop.\n"
if length($tab)>200 ; # simple-minded sanity check
}
print "\n\n" ;
} # URL
}
# Only report SSI errors if there are any
my($has_ssierrs) ;
foreach (sort keys %url) {
$has_ssierrs=1, last if @{$url{$_}{'ssierrs'}} ;
}
if ($has_ssierrs) {
print <<EOH ;
======================================================================
PROBLEMS WITH SERVER-SIDE INCLUDE (AKA SHTML) DIRECTIVES
------------------------------------------------------------
EOH
foreach (sort keys %url) {
my($u)= $url{$_} ;
if (@{$u->{'ssierrs'}}) {
print "$u->{'URL'}\n", '-' x 50, "\n" ;
printf "Total %s SSI Errors:\n", $#{$u->{'ssierrs'}}+1 ;
foreach my $i (0..$#{$u->{'ssierrs'}}) {
printf " %s) ", $i+1 ;
my($tab)= ' ' x (4+length($i+1)) ;
my($tab2) ;
foreach my $level (@{$u->{'ssierrs'}[$i]}) {
print "${tab2}file: $level->{'path'}\n" ;
print "${tab}in tag: $level->{'tag'}\n" ;
print "${tab}error: $level->{'errmsg'}\n"
if $level->{'errmsg'} ;
$tab.= ' ' ;
$tab2= $tab ;
}
}
print "\n\n" ;
}
}
}
unless ($has_statuserrs or $has_ssierrs) {
print <<EOH ;
======================================================================
<< NO ERRORS FOUND >>
EOH
}
print '=' x 70, "\n" ;
} # &make_verbose_report()
# Generate a one-line-per-URL report
sub make_short_report {
my($numurls)= scalar keys %url ;
print "Total $numurls URLs checked\n" ;
URL: foreach my $URL (sort keys %url) {
next if @INCLUDE_STATUS &&
!grep($url{$URL}{'status'}=~ /^$_/, @INCLUDE_STATUS) ;
next if grep($url{$URL}{'status'}=~ /^$_/, @EXCLUDE_STATUS) ;
print "$url{$URL}{'URL'}\t$url{$URL}{'status'}\n" ;
} # URL
}
# Print a summary of usage and exit
sub usage {
print <<EOF ;
Checklinks $CL_VERSION
To recursively check all HTML links on the local site, enter:
$0 <options> [ start-file | start-URL ] ...
Options include:
-v Generate full (verbose) report, including full
referral information and detailed SSI error
reporting.
-I <include-pattern> Only check URLs matching <include-pattern>.
-X <exclude-pattern> Don't check URLs matching <exclude-pattern>.
-i <include-status> Only report URLs whose response code starts with
the pattern <include-status>.
-x <exclude-status> Don't report URLs whose response code starts with
the pattern <exclude-status>. Default is to
exclude "200" responses only (i.e. "-x 200").
-d <max-depth> Traverse links no deeper than <max-depth>.
-f "File mode"-- only read files from the filesystem;
do not go through the HTTP server at all. This
will skip all URLs that point to CGI scripts.
-h "HTTP mode"-- use HTTP to check ALL URLs, even
if they could be read from the filesystem.
Incompatible with "-f" option.
-c <config-file> Read appropriate configuration parameters from
<config-file>, typically srm.conf. Use '-' to
read from STDIN. If a directory is named, use
"srm.conf" in that directory.
-q Print current configuration parameters.
-? Print this help message.
-- End command-line option processing.
Don't stack options like "-vf"; use "-v -f" instead.
For -I, -X, -i, and -x:
Values are interpreted as Perl 5 regular expressions.
Use multiple options to build a list (e.g. "-I include1 -I include2").
Use a value of '' to clear a list (e.g. -x '' means "report all responses",
"-x '' -x 401" means "report all but 401 responses").
As a special case, an empty -I or -i list implies no include-restrictions.
If an item is in both the include and exclude list, it is excluded.
Note that -I and -X restrict which URLs are traversed into, so they may
prune large areas of your Web structure.
EOF
exit ;
}
#----- debugging routines below ---------------------------------------
# Print current configuration settings
sub print_config {
print "\n----- OPTIONS SPECIFIC TO THIS EXECUTION -----------------------------\n\n" ;
print "Include only URLs containing one of the following patterns:\n",
( map { " $_\n" } @INCLUDE_PATTERNS ),
"\n"
if @INCLUDE_PATTERNS ;
print "Exclude URLs containing one of the following patterns:\n",
(map { " $_\n" } @EXCLUDE_PATTERNS ),
"\n"
if @EXCLUDE_PATTERNS ;
print "Only report response codes beginning with: ",
join(", ", @INCLUDE_STATUS), "\n"
if @INCLUDE_STATUS ;
print "Don't report response codes beginning with: ",
join(", ", @EXCLUDE_STATUS), "\n"
if @EXCLUDE_STATUS ;
print "\nMaximum search depth: $max_depth\n" if length($max_depth) ;
print <<EOS ;
----- INSTALLATION PARAMETERS ----------------------------------------
Local Host: $LOCAL_HOST
Document Root: $DOCUMENT_ROOT
User Web Directory: $USER_DIR
Default Filename(s): @DIRECTORY_INDEX
File extensions indicating a CGI program: @CGI_EXTENSIONS
File extensions indicating server-parsed HTML: @SHTML_EXTENSIONS
EOS
print "Directory Aliases:\n",
map { sprintf(" %15s ==> %s\n", $_, $ALIAS{$_}) }
sort keys %ALIAS,
"\n"
if keys %ALIAS ;
print "Directory Regular Expression Aliases:\n",
map { sprintf(" %15s ==> %s\n", $_, $ALIAS_MATCH{$_}) }
sort keys %ALIAS_MATCH,
"\n"
if keys %ALIAS_MATCH ;
print "Script Directory Aliases:\n",
map { sprintf(" %15s ==> %s\n", $_, $SCRIPT_ALIAS{$_}) }
sort keys %SCRIPT_ALIAS,
"\n"
if keys %SCRIPT_ALIAS ;
print "Script Directory Regular Expression Aliases:\n",
map { sprintf(" %15s ==> %s\n", $_, $SCRIPT_ALIAS_MATCH{$_}) }
sort keys %SCRIPT_ALIAS_MATCH,
"\n"
if keys %SCRIPT_ALIAS_MATCH ;
if ($ENV{'http_proxy'}) {
print "HTTP Proxy: $ENV{'http_proxy'}\n" ;
print "Except to hosts ending in: $ENV{'no_proxy'}\n"
if $ENV{'no_proxy'} ;
print "\n" ;
} else {
print "Not using any HTTP Proxy.\n" ;
}
print "Maximum HTTP redirections allowed for a URL: $MAX_REDIRECTS\n",
"Maximum number of tries to get a single URL: $MAX_ATTEMPTS\n\n";
print '-' x 70, "\n\n" ;
}
# print configuration, in a style more for debugging (mostly from srm.conf)
sub print_debug_config {
print <<EOF ;
DOCUMENT_ROOT= [$DOCUMENT_ROOT]
USER_DIR= [$USER_DIR]
DIRECTORY_INDEX= [@DIRECTORY_INDEX]
CGI_EXTENSIONS= [@CGI_EXTENSIONS]
SHTML_EXTENSIONS= [@SHTML_EXTENSIONS]
EOF
foreach (sort keys %ALIAS)
{ print "ALIAS{$_}= [$ALIAS{$_}]\n" }
foreach (sort keys %ALIAS_MATCH)
{ print "ALIAS_MATCH{$_}= [$ALIAS_MATCH{$_}]\n" }
foreach (sort keys %SCRIPT_ALIAS)
{ print "SCRIPT_ALIAS{$_}= [$SCRIPT_ALIAS{$_}]\n" }
foreach (sort keys %SCRIPT_ALIAS_MATCH)
{ print "SCRIPT_ALIAS_MATCH{$_}= [$SCRIPT_ALIAS_MATCH{$_}]\n" }
}
#----------------------------------------------------------------------
#
# SPARSE DOCUMENTATION ON PROGRAM INTERNALS:
#
#----------------------------------------------------------------------
#
# URLs are read directly from the local filesystem if possible, or
# downloaded or checked with HTTP GET and HEAD methods if not. CGI
# scripts are called through the HTTP server, even if local (since the
# resource their URLs refer to are not files).
#
#
# Global variables:
#
# %url holds all data regarding all URLs, using the text URL as the key:
#
# %url{$URL}{qw( URL filename referer depth
# ishtml iscgi islocal dontfollow
# status location numredirects numtries lasttried
# ssierrs
# hasbeenloaded)} <== only for testing
# URL is same as hash key
# ishtml means is type text/html; links MAY be extracted. (Used in
# main loop.)
# iscgi means is a CGI script; MUST NOT be read directly from
# filesystem. (Used in verify_url() and load_url().)
# islocal means served by local server:
# a) MAY be read directly from filesystem
# b) links MAY be extracted
# dontfollow means links MUST NOT be extracted.
# status begins with a number, but may have text afterward.
#
# islocal= (URL=~ m#^http://$LOCAL_HOST/#i) , i.e. redundant.
# ishtml and iscgi are guesses, may be 0, 1, or '' for unset.
# iscgi only matters for local URLs, but may safely be set for
# remote URLs.
# dontfollow is a hack to handle an obscure CGI-related situation.
#
# In addition to the standard HTTP status codes, 'status' may take one
# of the following values:
# 450 Can't read file: $!
# 451 SSI Error(s) (__ total)
# 600 Can't create socket: $@
# 601 Connection timed out
# 602 Incomplete response (%s of %s bytes)
# 603 Incomplete chunked response
#
# Handling of 602 and 603 is somewhat hackish-- overwrites real status
# line with artificial one.
#
# $url->{'ssierrs'} is a list of errors relating to SSI includes.
# Each error has a list of filenames representing the include
# chain. Each element in the chain stores the absolute
# pathname, the <!--#include--> tag which called it, and
# possibly an error message (usually only on the last file in
# the include-chain). Thus, the entire structure is
#
# $url->{'ssierrs'}[$errid][$levelsdeep]{qw( path tag errmsg )}
#
# This is only a memory hog with many errors of deeply nested files.
#
#
# @urlstoget: canonicalized list of URLs left to get, in order
# of appearance. List elements are pointers to %url elements.
# This array may grow from &extract_urls(), or be rearranged when
# a URL needs to be retried.
#
# Note that $url is normally a pointer, and $URL is normally a string.
#
# Files/paths are canonicalized by removing unneeded "./" and "../"
# segments.
# Directories are canonicalized to always end in "/", including in URLs;
# note that some system variables and local directory variables aren't so.
# URLs that point to "/" end in "/", e.g. "http://www.foo.com/".
#
#
# This program has a lot of unused functionality for possible extension,
# so don't get confused by routines that do more than they are used for.
#
#----------------------------------------------------------------------
#
# To do:
#
# * If you want a different output format (like in HTML), it should
# be easy enough to add.
# * This could be extended to check remote sites without much trouble.
# * Should probably support directories that don't have index.html.
# * Check that pointed-to fragments exist in target files
# * keep track of servers and don't hit them too often
# * support robots.txt
# * add option to read list of URLs from file
# * support HTTP Basic Authentication somehow. Note that currently, this
# reads local files even when they should be protected by .htaccess
# (unless using -h option).
# * Read list of local host names from gethostbyname() ?
# * check read permissions on files?
# * In the event multiple URLs redirect to the same URL, this could be a
# little more efficient if it saved the redirected loads/downloads.
#
#----------------------------------------------------------------------