mirror.pl

站点映像程序

#!/usr/bin/perl
# Make local directories mirror images of a remote sites
#
#
# Copyright (C) 1990 - 1998   Lee McLoughlin
#
# Permission to use, copy, and distribute this software and its
# documentation for any purpose with or without fee is hereby granted,
# provided that the above copyright notice appear in all copies and
# that both that copyright notice and this permission notice appear
# in supporting documentation.
#
# Permission to modify the software is granted, but not the right to
# distribute the modified code.  Modifications are to be distributed
# as patches to released version.
#
# This software is provided "as is" without express or implied warranty.
#
#
#
# $Id: mirror.pl,v 2.9 1998/05/29 19:01:07 lmjm Exp lmjm $
# $Log: mirror.pl,v $
# Revision 2.9  1998/05/29 19:01:07  lmjm
# Lots of changes.  See CHANGES since 2.8 file.
#
# Revision 2.8  1995/08/06  14:03:52  lmjm
# Trap a wider range of signals to aid in debugging under perl5
# Avoid looping processing symlinks.
#
# Revision 2.7  1995/08/06  13:59:00  lmjm
# No longer require socket.ph in this module.
# Escape at signs and dollars for perl5
# Make sure  proxy_gateway is at least null.
# Added ls_fix_mappings, failed_gets_excl, store_remote_listing, passive_ftp
#  and using_socks.
# Stop using dollar star as perl5 has dropped it.
# Process local directory listing before connecting to remote.
# Allow for remote_account pasword.
# Only one arg to undef, for early perl5's
# Use all capitals for file descriptors.
# Use ftp'close not ftp'quit
# Avoid file renaming under MACos
# Corrected file deleting.
#
# Revision 2.6  1994/06/10  18:28:27  lmjm
# Dropped debug statement.
#
# Revision 2.5  1994/06/06  18:39:21  lmjm
# Don't have . in the extra_path.
# Have 'internet-gateway' as the default proxy_gateway when INTERNET_HOST unset.
# Allow strip_cr (from Andrew).
# More symlink handling...
# Set type for vms correctly.
# Changed response from ftp'delete, also corrected path used.
#
# Revision 2.4  1994/04/29  20:11:09  lmjm
# Use correct variable for hostname
#
# Revision 2.3  1994/01/31  18:31:22  lmjm
# Allow for funny chars in filenames when calling the shell (Erez).
# Added compress_size_floor to avoid compressing small files (David).
# Added get_missing to just delete files not on remote system (Pieter).
# Don't try to delete old dirs if no time set (Pieter).
# Zap .dir$$ files, and keep then in $big_temp.
# Pretty print time in comparisons.
# Move the large comparision conditionals into routines (David).
# Allow for sites with limited filename lengths.
# Allow for deleted files when doing deletes.
# Don't delete dirs that are really symlinks.
#
# Revision 2.2  1993/12/14  11:09:15  lmjm
# Allow for no flock.
# Use installed socket.ph.
# Allow for system 5.
# Use percentage defaults on max_delete_*
# Checkout regexps before using.
# Allow for extra leading | in local_ignore.
# Return better exit codes.
# Fixups for recurse_hard.
# Smarter symlink handling.
#
# Revision 2.1  1993/06/28  14:59:00  lmjm
# Full 2.1 release
#
#

# Make sure we don't go recursive processing signals
$sigs = 0;
$max_sigs = 10;

# Am I on windoze?
$on_win = ($^O =~ /mswin/i);
$path_sep = $on_win ? ';' : ':';
$file_sep = $on_win ? '\\' : '/';
# Internally mirror uses / but when looking at names from environment allow
# for either
$file_sep_pat = $on_win ? "[\\/]" : "/"; # allow for c:\win/fred on windoze


# Default settings file loaded from a directory in PERLLIB
$defaults_file = 'mirror.defaults';
$load_defaults = 1;

# Try to find the default location of various programs via
# the users PATH then using $extra_path
if( ! $on_win ){
	$extra_path = '/usr/local/bin:/usr/new/bin:/usr/public/bin:/usr/ucb:/usr/bin:/bin:/etc:/usr/etc:/usr/local/etc';
}
if( $extra_path ne '' ){
	$ENV{ 'PATH' } .= $path_sep . $extra_path;
}

&trap_signals();

# If compressing a local file to send need somewhere to store the temp
# compressed version.
$big_temp = '/var/tmp';

# Hopefully we have flock.
$can_flock = 1;

# no debugging by default
$debug = 0;

# NOTE:
#  It is not an error for a program not to be found in the path as the user
# may be setting it as part of the package details or defaults.

# Used by the save_deletes option
$mv_prog = 'mv -f';

# compress must be able to take the -d arg to cause it to uncompress.
$sys_compress_prog = &find_prog( 'compress' );
$sys_compress_suffix = 'Z';

# Like compress gzip must be able to take -d
if( $gzip_prog = &find_prog( 'gzip' ) ){
	# Force maximum compression with gzip
	$gzip_level = ' -9';
	$gzip_prog .= $gzip_level;
	$gzip_suffix = 'gz';
	$old_gzip_suffix = 'z';
}

# A mail program that can be called as: "$mail_prog person_list'
# Can be overridden with the mail_prog keyword.
# If you use $mail_subject to pass extra arguments then remember that
# the mail program will need to know how to handle them.
$mail_prog = &find_prog( 'mailx' );
if( ! $mail_prog ){
	$mail_prog = &find_prog( 'Mail' );
}
if( ! $mail_prog ){
	$mail_prog = &find_prog( 'mail' );
}

# Used to remove directory heirarchies.  This program is passed the -rf
# arguments.
$rm_prog = &find_prog( 'rm' );

# Generate checksums
$sum_prog = &find_prog( 'sum' );

# SPECIAL NOTE: This is eval'd, so DONT put double-quotes (") in it.
# You can get local variables to appear as in the second example:
$mail_subject = '-s \'mirror update\'';
# $mail_subject = ' -s \'mirror update of $package\'';

# When scanning the local directory, how often to prod the remote
# system to keep the connection alive
$prod_interval = 60;

# Put the directory that mirror is actually in at the start of PERLLIB.
$dir = &real_dir_from_path( $0 );
unshift( @INC, $dir );

# Debian GNU/Linux stores mirror.defaults in /etc/mirror
$debian_defs = '/etc/mirror';
unshift( @INC, $debian_defs ) if -d $debian_defs;

# This, when eval'd, will get the current dir under windows NT/95
$win_getcwd = 'Win32::GetCwd';
	
# Make sure that your PERLLIB environment variable can get you
# all these or that they are installed.
require 'ftp.pl';
require 'lsparse.pl';
require 'dateconv.pl';

# Find some local details
# The current directory
$home = &cwd();
# The hostname
$hostname_cmd = &find_prog( 'hostname' );
if( $hostname_cmd ne '' ){
	chop( $hostname = `$hostname_cmd` );
}
if( $hostname eq '' ){
	$hostname_cmd = &find_prog( 'uname' );
	if( $hostname_cmd ne '' ){
		chop( $hostname = `$hostname_cmd -n` );
		if( $hostname eq '' ){
			chop( $hostname = `$hostname_cmd -l` );
		}
	}
}
if( $hostname eq '' ){
	$hostname = 'localhost';
}

if( $hn = (gethostbyname( "$hostname" ))[ 0 ] ){
	$hostname = $hn;
}

# Some systems hold the username in $USER, some in $LOGNAME.
$me = $ENV{'USER'} || $ENV{'LOGNAME'};

# Files matching this pattern are usually compressed.
$squished = '\.(Z|z|gz)$';

# special /bin/sh chars that must be escaped.
$shell_metachars = '\"|\$|`|\\\\';

# Remote directory parsing fail if not given input every readtime seconds.
$parse_time = 600;

# Timeout are not fatal unless you get more than this number of them.
$max_timeouts = 20;

# If connected to a site then this holds the site name.
$connected = '';

# Umask setting.
$curr_umask = sprintf( "0%o", umask );

# mapping from a pathname to a number - just to make the keys to assoc arrays
# shorter.
$map_init = 1;	# just so I know 0 is invalid

$tmp = "/tmp";
@assocs = ( 'local_map', 'remote_map' );

# A reasonable set of defaults
#   these are in the same order as the documentation - except where order is
#   important
$default{ 'hostname' } = $hostname; # The LOCAL hostname

$default{ 'package' } = '';	# should be a unique handle for the "lump" to be mirrored
$default{ 'site' } = '';	# site to connect to
$default{ 'remote_dir' } = '';	# remote directory to mirror
$default{ 'local_dir' } = '';	# local directory to copy into

$default{ 'remote_user' } = 'anonymous';  # the remote guest account name
$default{ 'remote_password' } = "$me\@$hostname";
$default{ 'remote_account' } = ''; # remote account name/passwd (for systems
				   # that use it.)
# Used for group and gpass.  (As in ftp.1 site group/gpass commands.)
$default{ 'remote_group' } = '';
$default{ 'remote_gpass' } = '';
$default{ 'timeout' } = 120;	# timeout ftp requests after this many seconds
$default{ 'failed_gets_excl' } = ''; # failed messages to ignore while getting,
				# if failed to ftp'get
$default{ 'ftp_port' } = 21;	# port number of remote ftp daemon
$default{ 'proxy' } = 0;	# normally use regular ftp
$default{ 'proxy_ftp_port' } = 4514; # default from Sun
$default{ 'proxy_gateway' } = "$ENV{ 'INTERNET_HOST' }";
				# Gateway to use for proxy
				# (Null if environment not set.)
$default{ 'using_socks' } = 0;	# Set the default perl version to the non-SOCKS one.
$default{ 'passive_ftp' } = 0;	# Set the default ftp usage not to use passive (PASV) ftp.
$default{ 'retry_call' } = 1;	# Retry the call if it fails first time
$default{ 'disconnect' } = 0;	# Force close at end of package EVEN if
				# next package is to the same site
$default{ 'remote_idle' } = '';	# Set the remote idle timer to this

$default{ 'get_patt' } = ".";	# regex of pathnames to retrieve
$default{ 'exclude_patt' } = ''; # regex of pathnames to ignore
$default{ 'local_ignore' } = ''; # regex of local pathnames to totally ignore
$default{ 'get_newer' } = 1;	# get remote file if its date is newer than local
$default{ 'get_size_change' } = 1; # get the file if size if different than local
$default{ 'make_bad_symlinks' } = 0; # prevent symlinks to non-existant files
$default{ 'follow_local_symlinks' } = ''; # Follow symlinks to pathnames matching this regexp.
$default{ 'get_missing' } = 1;	# Set get_missing to 0 to just delete files not on remote system
$default{ 'get_file' } = 1;	# perform get, not put by default
$default{ 'text_mode' } = 0;	# transfer in binary mode by default
$default{ 'strip_cr' } = 0;	# Delete \r (usefull when transfering from
				# mainframes -- set text_mode and strip_cr)
$default{ 'vms_keep_versions' } = 1; # Keep multiple VMS versions
$default{ 'vms_xfer_text' } = 'readme$|info$|listing$|\.c$';
				# pattern of VMS files to xfer in TEXT mode
				# (Case insensitive)
$default{ 'name_mappings' } = '';# remote to local pathname mappings
				# used to change layout or zap weird chars
	 			# (eg s:old:new)
$default{ 'external_mapping' } = '';# remote to local mapping by external routine
$default{ 'update_local' } = 0;	# Don't just update local dirs
$default{ 'max_days' } = 0;	# Ignore age of file
$default{ 'max_size' } = 0;	# If non-zero dont get files larger than this
$default{ 'chmod' } = 1;	# perform a chmod after an xfer

$default{ 'user' } = '';	# UID/user name to give to local pathnames
$default{ 'group' } = '';	# GID/group name to give to local pathnames
$default{ 'mode_copy' } = 0;	# true indicates to copy the mode bits
$default{ 'file_mode' } = 0444;	# Mode to give files created locally
$default{ 'dir_mode' } = 0755;	# mode to give directories created locally
$default{ 'force' } = 0;	# don't force by default
$default{ 'umask' } = 07000; # DONT allow setuid things by default
$default{ 'use_timelocal' }  = 1; # Use local time NOT gmt to timestamp files. (See also the -T flag.)
$default{ 'force_times' } = 1;	# Force local file times to match the original

$default{ 'do_deletes' } = 0;	# delete dest files if not in src tree
$default{ 'delete_patt' } = '.';# delete only files which match this pattern
$default{ 'delete_get_patt' } = 0;# true: set delete_patt to get_patt
$default{ 'delete_excl' } = ''; # regex of local pathnames to ignore when deleting
$default{ 'max_delete_files' } = '10%'; # Any more than this and DONT delete
$default{ 'max_delete_dirs' } = '10%'; # Any more than this and DONT delete
$default{ 'save_deletes' } = 0;	# save local files if not in remote
$default{ 'save_dir' } = 'Old';	# directory in which to create tree for keeping
				# files no longer in remote
$default{ 'store_remote_listing' } = ''; # Where to store remote site listings on local system

$default{ 'compress_patt' } = ''; # compress files matching this pattern
$default{ 'compress_excl' } = $squished; # dont compress regexp (case insensitive)
$default{ 'compress_prog' } = $sys_compress_prog; # Program to compress files.
$default{ 'compress_suffix' } = $sys_compress_suffix; # Suffix on compressed files
$default{ 'compress_conv_patt' } = '(\.Z|\.taz)$';
	# compress->gzip files matching this pattern
$default{ 'compress_conv_expr' } = 's/\.Z$/.gz/;s/\.taz$/.tgz/';
	# perl expressions to convert names of files from compress->gzip
$default{ 'compress_size_floor' } = 0;  # don't compress files < this size

$default{ 'split_max' } = 0;	# Files > this size can be split up.
$default{ 'split_patt' } = '';  # Files must match this pattern to be split
$default{ 'split_chunk' } = 100 * 1024; # Size of split-up chunks

$default{ 'remote_fs' } = 'unix'; # Remote filestore
	# Other posibilies dls, netware and vms
$default{ 'ls_lR_file' } = '';	# remote file containing ls-lR - else use remote ls
$default{ 'local_ls_lR_file' } = ''; # local file containing ls-lR
				# useful when first copying a large remote package
$default{ 'recursive' } = 1;	# true indicates to do recursive processing
$default{ 'recurse_hard' } = 0;	# true indicates have to cwd+ls for each remote
				# subdirectory - AVOID wherever possible.
$default{ 'flags_recursive' } = '-lRat'; # Flags passed to remote dir
$default{ 'flags_nonrecursive' } = '-lat'; # Flags passed to remote dir
$default{ 'ls_fix_mappings' } = '';# Correct pathnames in remote listings
				# (eg s:usr/spool/pub/::) to match reality

$default{ 'update_log' } = '';	# Filename where an update report is to be kept
$default{ 'mail_to' } = '';	# Mail a report to these addresses
$default{ 'mail_prog' } = $mail_prog; # the mail program (see $mail_prog)
$default{ 'mail_subject' } = $mail_subject; # Subject passed to mail_prog

$default{ 'comment' } = '';	# General comment used in report
# If mirroring a VERY large directory then it is best to put the assoc
# arrays in files (use command line switch -F. to turn on).
$default{ 'use_files' }  = 0;
$default{ 'interactive' } = 0;	# noninteractive copy default
$default{ 'skip' } = '';	# If set then skip this entry giving value as reason
$default{ 'verbose' } = 0;	# Verbose messages
$default{ 'algorithm' } = 0;	# The mirror algorithm to use
$default{ 'local_dir_check' } = 0; # Check local_dir exists before mirroring?

# I really want to drop this option.
$default{ 'delete_source' } = 0;# delete source after xfer (default = NO!!!)

@boolean_values = ( 'get_newer', 'get_size_change', 'do_deletes',
	'update_local',	'force_times', 'retry_call', 'recursive',
	'mode_copy', 'disconnect', 'interactive', 'text_mode',
	'force', 'get_file', 'verbose', 'proxy', 'delete_get_patt',
	'delete_source', 'save_deletes', 'use_files', 'use_timelocal',
	'make_bad_symlinks', 'recurse_hard', 'get_missing', 'strip_cr',
	'passive_ftp', 'using_socks', 'local_dir_check' );

%boolean_values = ();
&set_assoc_from_array( *boolean_values );

@regexp_values = ( 'get_patt', 'exclude_patt', 'local_ignore',
		  'delete_patt', 'delete_excl', 'split_patt', 'save_deletes',
		  'compress_patt', 'compress_excl', 'compress_conv_patt',
		  'failed_gets_excl', 'store_remote_listing' );

#
# message levels used by &msg( level, msg )
# if you call msg as &msg( msg ) the level is presumed to be just $pr.
$pr = 0;	# Always print out messages
$log = 1;	# push this messages onto @log

# The max number of directory failures under algorithm 1 before giving up.
$max_failed_dirs = 5;

#
# Exit status
$exit_status = 0;
$exit_status_xfers = 0;

# "#defines" for the above
$exit_xfers = 16;  # Add this to the exit code to show xfers took place
$exit_ok = 0;
$exit_fail = 1;
$exit_fail_noconnect = 2;

# -d		Turn on debugging - more -d's means more debugging.
# -ppattern	Just do packages matching pattern.
# -Rpattern	Skip till the first package name matches pattern then do all.
#		it and following packages.
# -n		Do nothing, just show what would be done.
# -F		Use files for assoc arrays (see also the variable use_files).
# -gsite:path
#		Get all files on given site.  If path matches .*/.+ then
#		it is the name of the directory and the last part is the
#		pattern of filenames to get.  If path matches .*/ then
#		it is the name of a directory and all its contents are retrieved.
#		Otherwise path is the pattern to be used in '/'.
# -r		Same as "-krecursive=false".
# -kvar=val	set variable to value.
# -uusername	Same as "-kremote_user=username", prompts for remote_password.
# -v		Print version and exit.
# -T		Dont transfer just force local timestamps to match remote.
# -N		Don't load mirror.defaults.
# -L		Generate a pretty list of what is being mirrored.
# -m 		Same as "-kmode_copy=true".

# -Cconfig_file
# -P 		Same as "-kget_file=false -kinteractive=true".
# -G		Same as "-kget_file=true -kinteractive=true".
# -t 		Same as "-ktext_mode=true".
# -f		Same as "-kforce=true".
# -sSITENAME	Same as "-ksite=SITENAME.
# -ULOGFILE	Set the upload log to LOGILE - if none given uses
#		the file $home/upload_log.$mday.$mon.$year

# -DUMP		Dump perl - to be later undumped --  THIS DOES NOT YET WORK!!!

sub msg_version
{
	&msg( '$Id: mirror.pl,v 2.9 1998/05/29 19:01:07 lmjm Exp lmjm $' . "\n" );
}

parse_args:
while( $ARGV[ 0 ] =~ /^-/ ){
	local( $arg ) = shift;

	if( $arg eq '-d' ){
		if( $debug == 2 ){
			&msg_version();
		}
		$| = 1;
		$debug++;
		next;
	}

	if( $arg =~ /^-(p)(.*)/ || $arg =~ /^-(R)(.*)/ ){
		local( $flag, $p ) = ($1, $2);
		if( $flag eq 'R' ){
			# Skip all packages till a match is made
			# then process ALL further packages
			$skip_till = 1;
		}
		if( ! $p ){
			# Must be -p/-R space arg
			$p = shift;
		}
		if( $p !~ /[a-zA-Z0-9]/ ){
			die "Invalid package name to -p of: $p\n";
			next;
		}
		# Only mirror the named packages
		$do_packages{ $p } = 1;
		$limit_packages = 1;
		next;
	}

	if( $arg eq '-n' ){
		# Do nothing - just show what would be done
		$dont_do = 1;
		$debug += 2;
		$| = 1;
		next;
	}

	if( $arg eq '-F' ){
		# Use files for the dir listings assoc lookups
		$use_files = 1;
		$command_line{ 'use_files' } = 1;
		next;
	}

	if( $arg eq '-T' ){
		# Don't actually get any files but just force
		# local timestamps to be the same on the remote system
		$timestamp = 1;
		$command_line{ 'force_times' } = 'true';
		next;
	}