#!/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_pathif( ! $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 -dif( $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;	}