mirror.pl

站点映像程序

	if( $arg =~ /^-g(.*)$/ ){
		# the next arg is the site:path to get
		local( $site_path ) = $1;

		if( ! $site_path ){
			# Must be -g space arg
			$site_path = shift;
		}
		
		# DONT use the system defaults!
		$load_defaults = 0;
		
		# This is probably interactive so print interactively
		$| = 1;
		
		if( $site_path =~ /(.*):(.*)?/ ){
			local( $site, $path ) = ($1, $2);
			push( @get_sites, $site );
			# Find the directory and files
			if( $path =~ m|^(.*)/([^/]*)$| ){
				if( $1 eq '' && $2 eq '' ){
					push( @get_paths, '/' );
					push( @get_patt, '.' );
				}
				elsif( $1 eq '' ){
					push( @get_paths, '/' );
				}
				else {
					push( @get_paths, $1 );
				}
				if( $2 eq '' ){
					push( @get_patt, '.' );
				}
				else {
					push( @get_patt, "^$2\$" );
				}
			}
			else {
				push( @get_paths, '.' );
				push( @get_patt, "^$path\$" );
			}
		}
		else {
			die "expected -gsite:path got $arg";
		}
		next;
	}

	if( $arg eq "-r" ){
		# no recursive copy
		$command_line{ 'recursive' } = 0;
		next;
	}

	if( $arg =~ /^-k(.*)=(.*)/ ){
	 	# set the keyword = value
		if( !defined( $default{ "$1" } ) ){
			warn "Invalid keyword $1\n";
		} else {
			$command_line{ "$1" } = $2;
		}
		next;
	}

	if( $arg =~ /^-u(.*)/ ){
		local( $user ) = $1;

		if( ! $user ){
			# must be -u space user
			$user = shift;
		}

		# override the user name
	        $command_line{ 'remote_user' } = $user;
		# and ask for a password
		$command_line{ 'remote_password' } = &get_passwd( $user );
		next;
	}

	if( $arg eq '-N' ){
		$load_defaults = 0;
		next;
	}

	if( $arg eq '-v' ){
		&msg_version();
		exit( 0 );
	}

        if( $arg eq '-L' ){
                # Generate a pretty list of what is being mirrored
                $pretty_print = 1;
                next;
        }

        if( $arg eq '-m' ){
                # propagate the mode
		$command_line{ 'mode_copy' } = 'true';
		next;
        }

	# Old command line interface flags
	if( $arg =~ /^-C(.*)/ ){
		# specify the config file
		local( $c ) = $1;
		if( $c !~ /./ ){
			die "Must give config file name -Cname ($arg)\n";
		}
		# Only mirror the named packages
	        push( @config_files, $c);
		next;
	}

        if( $arg eq '-P' ){
                # put files
		$command_line{ 'get_file' } = 'false';
		$command_line{ 'interactive' } = 'true';
		next;
        }

        if( $arg eq '-G' ){
                # get files
		$command_line{ 'get_file' } = 'true';
		$command_line{ 'interactive' } = 'true';
		next;
        }

        if( $arg eq '-t' ){
                # set the file mode to text
		$command_line{ 'text_mode' } = 'true';
		next;
        }

        if( $arg eq '-f' ){
                # force file transfers irregardless of date/size matches
		$command_line{ 'force' } = 'true';
		next;
        }

	if( $arg =~ /^-s(.*)/ ){
		# override the site name
		$command_line{ 'site' } = $1;
		next;
	}

	if( $arg =~ /^-U(.*)/ ){
		$upload_log = $1;
		if( $upload_log eq '' ){
			local( $sec,$min,$hour,$mday,$mon,$year,
				$wday,$yday,$isdst ) 
				= localtime( time );
			$mon++;
			$upload_log = "$home/upload_log.$mday.$mon.$year";
		}
			
		next;
	}

	if( $arg eq '-DUMP' ){
		# THIS DOES NOT YET WORK!!!!!
		$dumped_version = 1;
		warn "Dumping perl\n";
		dump parse_args;
	}

	warn "Unknown arg $arg, skipping\n";
}

# Handle multiline buffers in a sane way
# This is deprecated in perl-5.  Someone should add "/m" modifiers to any
# regexps that *really* need it, not all.
# $* = 1;

$interactive = $command_line{ 'interactive' };

if( ! $interactive ){
	local( $c );

	# The remainder of ARGV are package names
	foreach $c ( @ARGV ){
		push( @config_files, $c );
	}
}

if( $interactive && $limit_packages){
	die "Can not mix -p and interactive";
}

$value{ 'remote_user' } = $default{ 'remote_user' };
%value = ();
&set_defaults();

if( $load_defaults ){
	local( $dir, $mp );
	foreach $dir ( @INC ){
		local( $f ) = "$dir/$defaults_file";
		if( -f $f ){
			$mp = $f;
			last;
		}
	}
	if( $mp ){
		&msg( "defaults from $mp\n" ) if $debug > 2;
		splice( @config_files, 0, 0, $mp );
	}
	else {
		warn "No $defaults_file found in perl library path\n";
	}
}
elsif( $debug > 1 ){
	&msg( "not loading $defaults_file\n" );
}
		

&interpret_config_files();

# Shut down any remaining ftp session
&disconnect();

&msg( "All done, Exiting\n" ) if $debug;
exit( $exit_status + $exit_status_xfers );


$key = ''; # The current keyword
$value = ''; # the value for the keyword

sub interpret_config_files
{
	local( $fname );

	if( $#get_sites >= 0 ){
		while( $#get_sites >= 0 ){
			$value{ 'site' } = pop( @get_sites );
			$value{ 'remote_dir' } = pop( @get_paths );
			$value{ 'get_patt' } = pop( @get_patt );
			$value{ 'local_dir' } = '.';
			$value{ 'remote_user' } = 'anonymous';
			$exit_status = &do_mirror();
		}
		return;
	}
		

	if( $command_line{ 'interactive' } ){
		# No config file to read
		$value{ 'package' } = 'interactive';
		$exit_status = &do_mirror();
		return;
	}

	# if no configuration files were specified use standard input
	@ARGV = @config_files;
	&interpret_config();
}

sub interpret_config
{
	while( <> ){
		# Ignore comment and blank lines
		next if /^\s*#/ || /^\s*$/;
		
		&parse_line();
		
		# Is this a new package?
		if( $value{ 'package' } && $key eq 'package' ){
			# mirror the existing package
			$exit_status = &do_mirror();
			
			# reset
			&set_defaults();

			# Make sure I'm at the right place for <> to work!
			chdir $home;
		}
		
		if( $debug > 3 ){
			&msg( "$key \"$value\"\n" );
		}

		$value{ $key } = $value;

		# do an explicit close for each file so $. gets reset
		if( eof( ARGV ) ){
			if( $debug > 3 ){
				&msg( "-- end of config file \"$ARGV\"\n" );
			}
			close( ARGV );
		}
	}

	# Mirror the last package in the file
	if( $value{ 'package' } ){
		$exit_status = &do_mirror();
	}
}

# parse each line for keyword=value
sub parse_line
{
	local( $eqpl );
	local( $cont ) = '&';

	chop;
	if( /^\s*([^\s=+]+)\s*([=+])(.*)?$/ ){
		($key, $eqpl, $value) = ($1, $2, $3);
		# If the value ends in the continuation character then
		# tag the next line on the end (ignoring any leading ws).
		while( $value =~ /^(.*)$cont$/o && !eof ){
			$_ = <>;
			local( $v ) = $1;
			if( /^\s*(.*)$/ ){
				$value = $v . $1;
			}
		}
		if( $debug > 3 ){
			&msg( "read: $key$eqpl$value\n" );
		}
	}
	else {
		warn "unknown input in \"$ARGV\" line $. of: $_\n";
	}
	if( ! defined( $default{ "$key" } ) ){
		die "unknown keyword in \"$ARGV\" line $. of: $key\n";
	}
	if( $eqpl eq '+' ){
		$value = $value{ $key } . $value;
	}
}

# Initialise the key values to the default settings
sub set_defaults
{
	%value = %default;
	undef( $uid );
	undef( $gid );
}

# Override the current settings with command line values
sub command_line_override
{
	local( $key, $val, $overrides );

	while( ($key, $val) = each %command_line ){
		$overrides++;
		if( $boolean_values{ $key } ){
			# a boolean value
			$value{ $key } = &istrue( $val );
		} else {
			# not a boolean value
			$value{ $key } = $val;
		}
	}

	if( $debug > 4 ){
		if( $overrides ){
			&pr_variables( "keywords after command line override\n" );
		}
		else {
			&msg( "No command line overrides\n" );
		}
	}
}

# set each variable $key = $value{ $key }
sub set_variables
{
	local( $key, $val );

	while( ($key, $val) = each %value ){
		# for things like passwords it is nice to have the
		# real value in a file
		if( $val =~ /^\<(.*)$/ ){
			local( $val_name ) = $1;
			open( VAL_FILE, $val_name ) ||
				die "can't open value file $val_name\n";
			$val = <VAL_FILE>;
			close( VAL_FILE );
			chop $val if $val =~ /\n$/;
		}

		if( $boolean_values{ $key } ){
			# a boolean value
			eval "\$$key = &istrue( $val )";
		}
		else {
			# not a boolan value
			# Change all \ to \\ since \'s will be escaped in
			# the following string used in the eval.
			$val =~ s/([^\\])(')/$1\\$2/g;
			eval "\$$key = '$val'";
		}
		if( $key eq 'compress_prog' ){
			if( $val eq 'compress' ){
				$compress_prog = $sys_compress_prog;
				$compress_suffix = $sys_compress_suffix;
			}
			elsif( $val eq 'gzip' ){
				if( ! $gzip_prog ){
					die "Trying to use gzip but not found in PATH\n";
				}
				$compress_prog = $gzip_prog;
				$compress_suffix = $gzip_suffix;
			}
			elsif( $debug > 2 && $compress_prog ne $gzip_prog &&
			       $compress_prog ne $sys_compress_prog ){
				&msg( "compress_prog ($compress_prog) not compress or gzip, presuming program name\n" .
				      "- user must set compress_suffix\n" );
			}
			&upd_val( 'compress_prog' );
			&upd_val( 'compress_suffix' );
		}
	}
	if( $compress_patt ne '' && $compress_prog eq '' ){
		&msg( "compress_patt set but no compress_prog so compress_patt reset to nothing" );
		$compress_patt = '';
	}
		

	# Reset the umask if needed.
	# Do it here to try and get it done as early as possible.
	# If the user doesn't use octal umasks this will cause umask
	# to be called again unnecessarily - but that is pretty cheap.
	if( $umask && $umask != $curr_umask ){
		local( $val ) = $umask;
		$val = oct( $val ) if $val =~ /^0/;
		umask( $val );
		$curr_umask = sprintf( "0%o", umask );
	}

	&map_user_group();
}

sub upd_val
{
	local( $key ) = @_;
	if( $package eq 'defaults' ){
		$default{ $key } = $value{ $key };
	}
}

sub pr_variables
{
	local( $msg ) = @_;
	local( $nle ) = 60;
	local( $out ) = 0;
	local( $key, $val, $str );

	&msg( $msg );
	if( $get_file ){
		&msg( "package=$package  $site:$remote_dir -> $local_dir\n\t" );
	}
	else {
		&msg( "package=$package  $local_dir -> $site:$remote_dir\n\t" );
	}

	for $key ( sort keys( %value ) ){
		next if $key eq 'package' ||
			$key eq 'site' ||
			$key eq 'remote_dir' ||
			# Don't show passwords when interactive
			($interactive && $key eq 'remote_password') ||
			($interactive && $key eq 'remote_gpass');
		# Report the value in the actual variable
		$val = eval "\$$key";
		$str = "$key=\"$val\" ";
		&msg( $str );
		$out += length( $str );
		# Output newlines when a line is full
		if( $out > $nle ){
			$out = 0;
			&msg( "\n\t" );
		}
	}
	&msg( "\n" );
}

# Mirror the package, return exit_status
sub do_mirror
{
	local( $get_one_package ) = 0;

	$package = $value{ 'package' };
	
	if( $package eq 'defaults' ){
		# This isn't a real site - just a way to change the defaults
		%default = %value;

		return $exit_ok;
	}

	# Only do this package if given by a -Ppack argument
	if( $limit_packages && ! $do_packages{ $package } ){
		return;
	}

	if( $skip_till ){