#!/p/bin/perl # Make local directories mirror images of a remote sites # By Lee McLoughlin # You can do what you like with this except claim that you wrote it or # give copies with changes not approved by Lee. Neither Lee nor any other # organisation can be held liable for any problems caused by the use or # storage of this package. # # $Header: /a/swan/home/swan/staff/csg/lmjm/src/perl/mirror/RCS/mirror.pl,v 1.32 1992/03/20 21:01:07 lmjm Exp lmjm $ # $Log: mirror.pl,v $ # Revision 1.32 1992/03/20 21:01:07 lmjm # Cleaned up disconnect on error code. # Allow for uncompressing listing files. # Black magic the mail_prog variable to allow for more meaningful subject lines. # Added the TEMPORARY flag really_do_delete # Added proxy code from Edwards Reed. # Added flags_recursive and flags_nonrecursive. # Added delete_source # Added disconnect - force close at end of package even next package at same site # Allow variables to be read from a file if first char is a < # # Revision 1.31 1992/02/06 23:25:58 lmjm # Use /usr/bin/perl. # Added -L option. # Use new ftp.pl routines # # Revision 1.30 1992/01/14 11:02:55 lmjm # Corrected '-s arg' in mail_prog. # Added local_ls_lR_file - useful when first copying a large remote package # Corrected set_assoc_from_array. # # Revision 1.29 1991/12/18 16:58:04 lmjm # Just have a mail_prog variable with the '-s subject' as part of it. # Start on new -M option, load the mirror.defaults file and scan # packages dir. # Added -Rpackage - like -p but restarts a full-pull from that package. # Get the chdir in the right place so <> doesn't bomb. # # Revision 1.28 1991/12/06 18:13:48 lmjm # DONT use if( $path ) as a test to see if path is there. Fails if path # is the pathname "0" !!! # # Revision 1.27 1991/12/03 15:00:47 lmjm # Moved boolean_values and packages into an associative array, for speed. # # Revision 1.26 1991/12/03 13:52:54 lmjm # Added a chdir to make sure that <> works ok. # Added in patches from Amos to speed up the greps and fix splits. # Made the error prints for split's more helpful. # # Revision 1.25 1991/11/27 22:06:01 lmjm # Allow the associative arrays to be held in files - for very large directories. # Allow files to be split up. # Added 'a' to ls options. # Don't use filensames in printf format strings! (may contain a %) # Prod the remote server every nce and a while to keep the connection open. # # Revision 1.24 1991/10/23 22:42:26 lmjm # Upped the timeout. # Turned buffering back on again. I was mistaken in what effect it was having. # Call chat'close where necessary. # Added ls_lR_file option. # Try and allow for time zone changes when comparing dates. # # Revision 1.23 1991/10/07 18:30:39 lmjm # Added restarts. # Some more patches from Amos Shapira to correct somewhat dumb confile file loop. # Also now uses the value not the default value in key+value operations. # Neatened up error messages # # Revision 1.22 1991/10/02 14:48:49 lmjm # Corrected escaping of values. # Corrected use of ftp'restart (patch from Amos Shapira) # Corrected $user and $group resetting and arguments to chgrp. # # Revision 1.21 1991/09/24 01:21:20 lmjm # Look at the right var to decide if there is mail to send. # # Revision 1.20 1991/09/20 22:31:19 lmjm # Make the output look prettier! # Corrected some typos. # # Revision 1.19 1991/09/20 21:13:09 lmjm # Gave -U a default. # # Revision 1.18 1991/09/20 20:55:34 lmjm # Added an -Ufile option just to record uploads. # # Revision 1.17 1991/09/17 22:53:18 lmjm # Avoid the CHMOD check unless necessary # More playing with debug levels. # Added back in the timestamp code. # # Revision 1.16 1991/09/12 22:40:27 lmjm # Changed arguments over to be more compatible with the original. # Don't mirror a remote site if it is really the local host! # Added deletion code. # Made prompt for password more meaningful. # # Revision 1.15 1991/09/06 19:53:54 lmjm # Merged in considerable changes by Alan Martllo for sending files, # plus command line work, plus internal changes to work as a series of steps... # Changed debug printing to be a little more appropriate. # # Revision 1.14 1991/09/04 14:17:02 lmjm # Made debug level 1 more useful. # Print site:remote_dir (not local_dir) in messages. # # Revision 1.13 1991/08/29 16:23:53 lmjm # Added some new keywords. # Stay connected to the site when done in case next entry is from the same # site. # Only die on really fatal errors. # Treat symlinks more like files when checking it. # # Revision 1.12 1991/08/21 10:45:58 lmjm # Allow for line continuation (& at end of line) # Don't create local dirs or symlinks when -n turned on. # # Revision 1.11 1991/08/20 11:51:52 lmjm # added more detail to the log and mail messages. # Correct the timestamp code. # # Revision 1.10 1991/08/19 09:53:41 lmjm # Corrected -p, was pushing wrong variable # # Revision 1.9 1991/08/16 22:30:06 lmjm # Added -v option to print the version. # # Revision 1.8 1991/08/16 22:17:45 lmjm # Added the -T option to re-timestamp the local archive. # Check the argument to the -p flag. # Added the update_local option. # Allow key+value # Tried to make the logging messages more meaningful. # # Revision 1.7 1991/08/14 21:02:47 lmjm # Implement mail_to, update_log, compress_patt and compress_excl # Local directory scaned by direct perl. # Allow for unreadable files. # # Revision 1.6 1991/08/14 17:50:14 lmjm # Short circuit mkdirs if the path already exists. # Added in the compression code. # # Revision 1.5 1991/08/09 22:31:01 lmjm # Added a simple name_mappings (it can be a single s/// expression) # get_file via a temp file # Corrected (YET AGAIN) the max_age code. # Made mkdirs more sensible. # # Revision 1.4 1991/08/09 21:35:02 lmjm # Parse args rather than use -s. # Added -pPackage arg to limit packages looked at. # Reset all the logging levels. # # Revision 1.3 1991/08/09 20:10:15 lmjm # Now use the package keyword to name entries. # Don't recurse by setting a suitable exclude_patt # Corrected age checking and null directory creation. # # Revision 1.2 1991/08/09 18:06:56 lmjm # Call chown/chgrp if necessary. # Quit remote site correctly # Compared time the wrong way around # Create dirs/symlinks locally. # Set file/dir modes # # Revision 1.1 1991/08/08 20:19:27 lmjm # Initial revision # $defaults_file = 'mirror.defaults'; # Define $chowngrp if your chown takes user.group as an arg $chowngrp = '/usr/etc/chown'; $chown = '/usr/etc/chown'; $chgrp = '/usr/bin/chgrp'; $compress_prog = '/usr/ucb/compress'; $uncompress_prog = '/usr/ucb/uncompress'; # A mail program that can be called as: "$mail_prog person_list' # Can be overridden with the mail_prog keyword. # SPECIAL NOTE: This line is eval'd, so DONT put double-quotes (") in it. # You can get local variables to appear as in the second example: $mail_prog = '/usr/bin/mail -s \'mirror update\''; # $mail_prog = '/usr/bin/mail -s \'mirror update of $package\''; # Send status only once to the admin. @MAIL_all = (); @MAIL_sub = (); # Used to remove directory heirarchies $rm_prog = "/bin/rm -rf "; # Generate checksums $sum_prog = "/usr/bin/sum"; # When scanning the local directory how often to prod the remote # system to keep the connection alive $prod_interval = 90; # Make sure that your PERLLIB environment variable can get you # all these require 'getopts.pl'; require '/pub/OS/Linux/YLLAPITO/bin/mirror/ftp.pl'; require '/pub/OS/Linux/YLLAPITO/bin/mirror/chat2.pl'; require '/pub/OS/Linux/YLLAPITO/bin/mirror/lsparse.pl'; require '/pub/OS/Linux/YLLAPITO/bin/mirror/dateconv.pl'; require '/pub/OS/Linux/YLLAPITO/bin/mirror/socket.ph'; # Find some local details chop( $home = `pwd` ); chop( $hostname = `hostname` ); if( $hn = (gethostbyname( "$hostname" ))[ 0 ] ){ $hostname = $hn; } $me = $ENV{ 'USER' }; $retry_pause = 60; # Pause before retrying $squished = '\.[zZ]$'; # Files matching this pattern are usually compressed # If connected to a site then this holds the site name. $connected = ''; # If mirroring a VERY large directory then it is best to put the assoc # arrays in files $use_files = 0; $tmp = "/tmp"; @assocs = ( 'local_time', 'local_size', 'local_type', 'local_mode', 'remote_time', 'remote_size', 'remote_type', 'remote_mode' ); # Create a reasonable set of defaults $default{ 'package' } = ''; # should be a unique handle for the "lump" to be mirrored $default{ 'comment' } = ''; # General comment used in report $default{ 'skip' } = ''; # If set then skip this entry giving value as reason $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{ 'get_patt' } = "."; # regex of pathnames to retrieve $default{ 'exclude_patt' } = ''; # regex of pathnames to ignore $default{ 'update_local' } = 0; # Don't just update local dirs $default{ 'local_ignore' } = ''; # regex of local pathnames to totally ingnore $default{ 'do_deletes' } = 0; # delete local files if not in remote $default{ 'really_do_deletes' } = 0; # actually do deletions! $default{ 'delete_excl' } = ''; # regex of local pathnames to ignore when deleting $default{ 'max_days' } = 0; # Ignore age of file $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{ '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{ 'name_mappings' } = '';# remote to local pathname mappings (eg s:old:new) $default{ 'get_newer' } = 1; # get the remote file if its date is newer than local $default{ 'get_size_change' } = 1; # get the file if size if different than local $default{ 'compress_patt' } = ''; # compress files matching this pattern $default{ 'compress_excl' } = $squished; # dont compress regexp $default{ 'force_times' } = 1; # Force local file times to match the original $default{ 'retry_call' } = 1; # Retry the call if it fails first time $default{ 'update_log' } = ''; # Filename where an update report is to be kept $default{ 'mail_to' } = ''; # Mail a report to these addresses $default{ 'user' } = ''; # UID/user name to give to local pathnames $default{ 'group' } = ''; # GID/group name to give to local pathnames $default{ 'file_mode' } = 0444; # Mode to give files created locally $default{ 'dir_mode' } = 0755; # mode to give directories created locally #$default{ 'timeout' } = 40; # timeout ftp requests after this many seconds $default{ 'timeout' } = 120; # timeout ftp requests after this many seconds $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' }; # used if($proxy) $default{ 'recursive' } = 1; # flag indicating if we need to do recursive processing $default{ 'flags_recursive' } = '-lRat'; # Flags passed to remote dir $default{ 'flags_nonrecursive' } = '-lat'; # Flags passed to remote dir $default{ 'mode_copy' } = 0; # flag indicating if we need to copy the mode bits $default{ 'interactive' } = 0; # noninteractive copy default $default{ 'text_mode' } = 0; # transfer in binary mode by default $default{ 'force' } = 0; # don't force by default $default{ 'get_file' } = 1; # perform get, not put by default $default{ 'verbose' } = 0; # Verbose messages $default{ 'remote_fs' } = 'unix'; # Remote filestore $default{ 'mail_prog' } = $mail_prog; # the mail programme (see $mail_prog) $default{ 'delete_source' } = 0;# delete source after xfer (default = NO!!!) $default{ 'disconnect' } = 0; # Force close at end of package EVEN if # next package is to the same site @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_source', 'really_do_deletes' ); %boolean_values = (); &set_assoc_from_array( *boolean_values ); @regexp_values = ( 'get_patt', 'exclude_patt', 'local_ignore', 'delete_excl', 'split_patt', 'compress_patt', 'compress_excl' ); # # -cconfig_file # -m (same as "-kmode_copy=true" # -sSITENAME (same as "-ksite=SITENAME) # -uUSERNAME (same as "-kremote_user=USERNAME", prompts for remote_password) # -t (same as "-ktext_mode=true") # -P (same as "-kget_file=false -kinteractive=true") # -G (same as "-kget_file=true -kinteractive=true") # -f (same as "-kforce=true") # -r (same as "-krecursive=false") while( $ARGV[ 0 ] =~ /^-/ ){ local( $arg ) = shift; if( $arg eq '-M' ){ # Use a master config file - still in progress if( ! -r $defaults_file ){ die "No file: $defaults_file"; } push( @config_files, $defaults_file ); # Add all the config files from the configs directories &add_all_files( 'packages' ); next; } if( $arg eq '-L' ){ # Generate a pretty list of what is being mirrored $pretty_print = 1; next; } if( $arg eq '-d' ){ # Hack: everything works a LOT more reliably with buffering turned off. $| = 1; $debug++; next; } if( $arg =~ /-v/ ){ print '$Id: mirror.pl,v 1.32 1992/03/20 21:01:07 lmjm Exp lmjm $' . "\n"; exit; } if( $arg eq '-F' ){ # Use files for the dir listings assoc lookups $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++; $command_line{ 'force' } = 'true'; next; } if( $arg eq '-n' ){ # Do nothing - use with debugging to show what would be # done $dont_do = 1; $debug = 2; $| = 1; 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 !~ /[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 =~ /^-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 '-m' ) { # propogate the mode $command_line{ 'mode_copy' } = 'true'; 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' ) { # set force mode $command_line{ 'force' } = 'true'; next; } if( $arg =~ /^-s(.*)/ ){ # override the site name $command_line{ 'site' } = $1; next; } if( $arg eq "-r" ){ # no recursive copy $command_line{ 'recursive' } = 0; next; } if( $arg =~ /^-k(.*)=(.*)/ ) { # set the keyword = value if( !defined( $default{ "$1" } ) ) { print "Invalid keyword $1\n"; } else { $command_line{ "$1" } = $2; } next; } if( $arg =~ /^-u(.*)/ ){ local( $pass ); # override the user name $command_line{ 'remote_user' } = $1; # and ask for a password $command_line{ 'remote_password' } = &get_passwd( $1 ); next; } if( $arg =~ /^-U(.*)/ ){ $upload_log = $1; if( $upload_log eq '' ){ local($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = gmtime(time); $mon++; $upload_log = "$home/upload_log.$mday.$mon.$year"; } next; } print "Unknown arg $arg, skipping\n"; } # Handl multi-line buffers in a sane way $* = 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"; } &set_defaults(); &interpret_config_files(); # Shut down any remaining ftp session &disconnect(); # Sending mail if ( $#MAIL_all >= 0 && $mail_to =~ /./ ) { local( $com ); eval "\$com = \"|$mail_prog $mail_to\""; if ( ! open( mail, $com ) ) { print "Cannot run: $com\n"; return; } else { print mail "Subject: mirror update for /pub/OS/Linux\n"; print mail "\nMirrored:\n"; print mail @MAIL_sub; print mail "\n", '-' x 70, "\n\n"; print mail @MAIL_all; close( mail ); } } print "All done, Exiting\n" if $debug; exit( 0 ); $key = ''; # The current keyword $value = ''; # the value for the keyword sub interpret_config_files { local( $fname ); if( $command_line{ 'interactive' } ){ # No config file to read &do_mirror(); $value{ 'package' } = 'interactive'; return; } # if no configuration files were specified then read the 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 &do_mirror(); # reset &set_defaults(); # Make sure I'm at the right place for <> to work! chdir $home; } if( $debug > 3 ){ print "$key \"$value\"\n"; } $value{ $key } = $value; # do an explicit close for each file so $. gets reset if( eof( ARGV ) ){ if( $debug > 3 ){ print "-- end of config file \"$ARGV\"\n"; } close( ARGV ); } } # Mirror the last package in the file if( $value{ 'package' } ){ &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$/ && !eof ){ $_ = <>; local( $v ) = $1; if( /^\s*(.*)$/ ){ $value = $v . $1; } } if( $debug > 3 ){ print "read: $key$eqpl$value\n"; } } else { print "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; } # 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 > 2 ){ if( $overrides ){ &pr_keywords( "keywords after command line override\n" ); } else { print "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( $value =~ /^\<(.*)$/ ){ local( $val_name ) = $1; open( VAL_FILE, $val_name ) || die "can't open value file $val_name\n"; $value = ; close( VAL_FILE ); chop $value if ( $value =~ /\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'"; } } } sub pr_keywords { local( $msg ) = @_; local( $nle ) = 4; local( $out ) = $nle; local( $key, $val ); print $msg; print "package=$package $site:$remote_dir\n\t"; while( ($key, $val) = each %value ){ next if( $key eq 'package' || $key eq 'site' || $key eq 'remote_dir' || # Don't show passwords when interactive ($interactive && $key eq 'remote_password') ); print "$key=\"$val\" "; $out --; if( $out == 0 ){ $out = $nle; print "\n\t"; } } print "\n"; } # Mirror the package sub do_mirror { $package = $value{ 'package' }; if( $package eq 'defaults' ){ # This isn't a real site - just a way # to change the defaults %default = %value; return; } # Only do this package if given by a -Ppack argument if( $limit_packages && ! $do_packages{ $package } ){ return; } if( $skip_till ){ # Found a package so process all packages from now on $skip_till = $limit_packages = 0; } # set things from the command line arguments &command_line_override(); # set each variable $key = $value{ $key } &set_variables(); if( $debug == 1 && $package ){ print "\npackage=$package $site:$remote_dir\n"; } elsif( $debug > 1 ){ &pr_keywords( "\n" ); } # Check out the regexps local( $t ) = 'x'; foreach $r ( @regexp_values ){ local( $val ) = $value{ $r }; next if( ! $val ); eval '$t =~ /$val/'; if( $@ ){ local( $err ); chop( $err = $@ ); print "Problem with regexp $r ($err), skipping package\n"; return; } } # Don't bother if tryying to mirror here! if( !$interactive && !$force && ((gethostbyname( $site ))[0] eq $hostname) ){ print "Skipping $site as it is really here!\n"; return; } chdir $home; $max_age = 0; if( $value{ 'max_days' } ne '0' ){ $max_age = time - ($value{ 'max_days' } * 24 * 60 * 60); print "max_age = $max_age\n" if( $debug > 1); } if( $debug ){ # Keep the ftp debugging lower than the rest. &ftp'debug( $debug - 1); } else { &ftp'debug( $verbose ); } &ftp'set_timeout( $timeout ); # Useful string in prints $XFER = $get_file ? "get" : "put"; # create the list of items to copy @transfer_list = (); if( $interactive ){ # copy the remainder of items from argv to the transfer list while (@ARGV) { # copy the local directory if( @ARGV ){ push( @transfer_list, shift( @ARGV ) ); } # copy the remote directory if( @ARGV ){ push( @transfer_list, shift( @ARGV ) ); } else { die "remote directory must be specified\n"; } # copy the pattern, if available if( @ARGV ){ push( @transfer_list, shift( @ARGV ) ); } else { push( @transfer_list, $default{ 'get_patt' } ); } } if( $debug > 1 ){ local( $t ); @t = @transfer_list; while( @t ){ printf( "local_dir=%s remote_dir=%s patt=%s\n", shift( @t ), shift( @t ), shift( @t ) ); } } } else { push( @transfer_list, $local_dir ); push( @transfer_list, $remote_dir ); push( @transfer_list, $get_patt ); } if( $update_local && $get_patt ){ if( $get_patt ne $default{ 'get_patt' } ){ print "Cannot mix get_patt and update_local. get_patt ignored\n"; } $get_patt = ''; } if( !$site || (!$interactive && (!$local_dir || !$remote_dir)) ){ print "Insufficient details for package to be fetched\n"; print "Must give at least, site, remote_user, remote_dir and local_dir\n"; return; } if( $pretty_print ){ # Don't actually mirror just print a pretty list # of what would be mirrored. This is for mailing to # people if( $skip ){ return; } print "$package \"$comment\"\n"; print " $site:$remote_dir --> $local_dir\n\n"; return; } if( $skip ){ print "Skipping package $package because $skip\n"; return; } if( $split_max && $split_max <= $split_chunk ){ print "split_max ($split_max) <= split_chunk ($split_chunk), this is senseless - skipping package\n"; return; } if( $split_chunk && ($split_chunk & 511) ){ print "split_chunk ($split_chunk) must be a multiple of 512 bytes - skipping package\n"; return; } local( $con ) = &connect(); if( $con <= 0 ){ print "Cannot connect, skipping package\n"; &disconnect(); return; } if( $con == 1 ){ print "login as $remote_user\n"; $curr_remote_user = $remote_user; if( ! &ftp'login( $remote_user, $remote_password ) ){ print "Cannot login, skipping package\n"; &disconnect(); return; } $can_restart = (&ftp'restart(0) == 1); if( $debug > 1 ){ printf "Can %sdo restarts\n", $can_restart ? '' : "not "; } if( ! &ftp'type( $text_mode ? 'A' : 'I' ) ){ print "Cannot set type\n"; } } else { # Already connected to this site - so no need to login again print "Already connected to site $site\n" if( $debug ); } if( ! $get_file ){ local( @rhelp ) = &ftp'site_commands(); $remote_has_chmod = grep( $_ eq 'CHMOD', @rhelp); if( $debug > 2 ){ print "remote site " . ($remote_has_chmod ? "has" : "hasn't") . " got chmod\n"; } } @log = (); while( @transfer_list ) { # get files $local_dir = shift( @transfer_list ); $remote_dir = shift( @transfer_list ); $get_patt = shift( @transfer_list ); # Clear all details @xfer_dest = @xfer_src = @xfer_attribs = @things_to_make = (); if( $use_files ){ &create_assocs(); } if( !&get_local_directory_details() ){ print "Cannot get local directory details ($local_dir)\n"; &disconnect(); return; } # Create a get_patt from the contents of the local directory if( $update_local && $#get_top >= 0 ){ $get_patt = '^' . join( '|^', @get_top ); $get_patt =~ s/\.Z\b//g; print "get_patt = $get_patt\n" if( $debug ); } if( !&get_remote_directory_details() ){ print "Cannot get remote direcory details ($remote_dir)\n"; &disconnect(); return; } if( $get_file ){ &compare_dirs( *remote_sorted, *remote_time, *remote_size, *remote_type, *local_sorted, *local_time, *local_size, *local_type ); } else { &compare_dirs( *local_sorted, *local_time, *local_size, *local_type, *remote_sorted, *remote_time, *remote_size, *remote_type ); } if( $timestamp ){ &set_timestamps(); next; } # Do things! if( $do_deletes ){ if( $get_file ){ &compare_dirs_for_deletes( *local_sorted, *local_type, *remote_sorted, *remote_type ); } else { &compare_dirs_for_deletes( *remote_sorted, *remote_type, *local_sorted, *local_type ); } &do_deletes(); } &make_things(); &do_all_transfers(); # No more transfers if the connection has died. last if( ! $connected ); } # Should I force a disconnect now? if( $connected && $disconnect ){ &disconnect(); } if( $dont_do || $timestamp ){ # Don't generate logs/email return; } local( $now ); chop( $now = `date` ); if( $update_log ){ if( ! open( logg, ">>$update_log" ) ){ print "Cannot append to $update_log\n"; return; } print logg "mirroring $package ($site:$remote_dir) completed successfully @ $now\n"; print logg @log; close( logg ); } if( $#log >= 0 && $mail_to =~ /./ ){ # local( $com ); # eval "\$com = \"|$mail_prog $mail_to\""; # if( ! open( mail, $com ) ){ # print "Cannot run: $com\n"; # return; # } # print mail "Mirrored $package ($site:$remote_dir) $comment @ $now\n"; push( @MAIL_sub, "\t" . "$package ($site:$remote_dir)\n" ); push( @MAIL_all, "Mirrored $package ($site:$remote_dir) $comment @ $now\n" ); # print mail @log; push( @MAIL_all, @log ); push( @MAIL_all, "\n" . ( "-" x 30 ) . "\n\n" ); # close( mail ); } } sub disconnect { if( $connected ){ print "disconnecting from $connected\n" if( $debug ); if( ! $ftp'fatalerror ){ &ftp'quit(); } } &chat'close(); $connected = ''; if( $use_files ){ # Close and zap. &delete_assocs(); } } # Connect to the site # Return 0 on a fail, # 1 if a connection was successfully made, # 2 if already connected to the site sub connect { local( $attempts ) = 1; # Only retry ONCE! Be friendly. local( $res ); if( $connected eq $site && $curr_remote_user eq $remote_user ){ # Already connected to this site! return 2; } # Clear out any session I may still be in &disconnect(); $res = &ftp'open( $site, $ftp_port, $retry_call, $attempts ); if( $res == 1 ){ # Connected $connected = $site; } return $res; } # This just prods the remote ftpd to prevent time-outs sub prod { if( $debug > 2 ){ print " prodding remote ftpd\n"; } &ftp'pwd(); } sub get_local_directory_details { local( @dirs, $dir ); local( $last_prodded ) = time; # when I last prodded the remote ftpd undef( @local_sorted ); if( ! $use_files ){ undef( %local_time, %local_size, %local_type, %local_mode ); } @get_top = (); print "Scanning local directory $local_dir\n"; if( ! -d $local_dir ){ if( $dont_do || $timestamp ){ return 1; } print "$local_dir no such directory - creating it\n"; if( &mkdirs( $local_dir ) ){ push( @log, "Created dir $local_dir\n" ); } } if( !chdir( $local_dir ) ){ print "Cannot change directory to $local_dir\n"; return 0; } if( $local_dir =~ m,^/, ){ $cwd = $local_dir; } else { chop( $cwd = `pwd` ); } # @dirs is the list of all directories to scan # As subdirs are found they are added to the end of the list # and as @dirs = ( "." ); local( $dir_level ) = 0; while( defined( $dir = shift( @dirs ) ) ){ local( $path, $time, $size, $type, $mode ); # Prod the remote system from time to time # To prevent time outs if( time > ($last_prodded + $prod_interval) ){ $last_prodded = time; &prod(); } if( !opendir( dir, $dir ) ){ print "Cannot open local directory $dir, skipping it\n"; next; } local( $name ); while( defined( $name = readdir( dir ) ) ){ local( $linkname ); local( $isdir ); next if( $name eq '.' || $name eq '..' || ($local_ignore && $name =~ /$local_ignore/) ); $path = "$dir/$name"; $path =~ s,(^|/)\./,,; if( -l $path ){ local( $value ) = readlink( $path ); local( $dev,$ino,$fmode,$nlink,$uid,$gid,$rdev,$ssize, $atime,$mtime,$ctime,$blksize,$blocks ) = lstat( _ ); $size = $ssize; $time = $mtime; $type = "l $value"; $mode = $fmode; } elsif( ($isdir = (-d $path)) || -f $path ){ local( $dev,$ino,$fmode,$nlink,$uid,$gid,$rdev,$ssize, $atime,$mtime,$ctime,$blksize,$blocks ) = stat( _ ); $size = $ssize; $time = $mtime; $mode = $fmode; if( $isdir ){ push( @dirs, $path ); $path .= '/'; $type = 'd'; } else { $type = 'f'; } if( $dir_level == 0 && $update_local ){ push( @get_top, $path ); } } else { print "unknown file type $path, skipping\n"; next; } # I can only really cope with the permissions bits. $mode &= 0777; if( $debug > 2){ printf "local: %s %s %s %s 0%o\n", $path, $size, $time, $type, $mode; } push( @local_sorted, $path ); $local_time{ $path } = $time; $local_size{ $path } = $size; $local_type{ $path } = $type; $local_mode{ $path } = $mode; } closedir( dir ); $dir_level++; if( ! $recursive ){ last; } } return 1; } sub get_remote_directory_details { print "Scanning remote directory $remote_dir\n"; undef( @remote_sorted ); if( ! $use_files ){ undef( %remote_time, %remote_size, %remote_type, %remote_mode ); } if( ! &ftp'cwd( $remote_dir ) ){ if( $get_file ){ # no files to get return 0; } print "Failed to change to remote directory ($remote_dir) trying to create it\n"; &mkdirs( $remote_dir ); if( ! &ftp'cwd( $remote_dir ) ){ print "Cannot change to remote directory ($remote_dir) because: $ftp'response\n"; return 0; } } local( $rls ); if( $local_ls_lR_file ){ print " Using local file $local_ls_lR_file for remote dir listing\n"; if( ! open( dirtmp, $local_ls_lR_file ) ){ print "Cannot open $local_ls_lR_file\n"; return 0; } $rls = "main'dirtmp"; } elsif( $ls_lR_file ){ local( $dirtmp ); $dirtmp = "/tmp/.dir$$"; if( $ls_lR_file = /\.Z$/ ){ $dirtmp .= '.Z'; } print " Getting directory listing from remote file $ls_lR_file\n"; if( ! &ftp'get( $ls_lR_file, $dirtmp, 0 ) ){ print "Cannot get dir listing file\n"; return 0; } if( $dirtmp =~ /\.Z$/ ){ local( $f ) = $dirtmp; $f =~ s/'/\\'/g; &sys( "$uncompress_prog '$f'" ); $dirtmp = ~s/\.Z$//; } open( dirtmp, $dirtmp ) || die "Cannot open $dirtmp"; $rls = "main'dirtmp"; } else { if( ! &ftp'type( 'A' ) ){ print "Cannot set type to ascii for dir listing\n"; } if( !&ftp'dir_open( $recursive ? $flags_recursive : $flags_nonrecursive ) ){ print "Cannot get remote directory listing because: $ftp'response\n"; return 0; } $rls = "ftp'NS"; } $lsparse'fstype = $remote_fs; $lsparse'name = $package; &lsparse'reset( '' ); while( !eof( $rls ) ){ local( $path, $size, $time, $type, $mode ) = &lsparse'line( $rls ); last if( !$path ); if( $debug > 2 ){ printf "remote: %s %s %s %s 0%o\n", $path, $size, $time, $type, $mode; } push( @remote_sorted, $path ); $remote_time{ $path } = $time; $remote_size{ $path } = $size; $remote_type{ $path } = $type; $remote_mode{ $path } = $mode; } if( $local_ls_lR_file ){ close( dirtmp ); } elsif( $ls_lR_file ){ close( dirtmp ); unlink( $dirtmp ); } else { &ftp'dir_close(); # Could optimise this out - but it makes sure that # the other end gets a command straight after a possibly # long dir listing. if( ! &ftp'type( $text_mode ? 'A' : 'I' ) ){ print "Cannot reset type after dir listing\n"; } } return 1; } sub compare_dirs { local( *src_paths, *src_time, *src_size, *src_type, *dest_paths, *dest_time, *dest_size, *dest_type ) = @_; local( $src_path, $dest_path, $dest_index, $i ); local( $last_prodded ) = time; # when I last prodded the remote ftpd print "compare directories for xfer\n"; for( $i = 0; $i <= $#src_paths; $i++ ){ $dest_path = $src_path = $src_paths[ $i ]; # Prod the remote system from time to time # To prevent time outs. Only look once every 10 files # to save on unnecessary systems calls. if( ($i % 10 == 5) && time > ($last_prodded + $prod_interval) ){ $last_prodded = time; &prod(); } if( $debug > 2 ){ print "Compare src $src_path: $src_time{ $src_path }"; print " $src_size{ $src_path } $src_type{ $src_path }\n"; } # Should I compress this file? local( $compress ) = 0; if( $src_type{ $src_path } eq 'f' && $compress_patt && $src_path =~ /$compress_patt/ && !($compress_excl && $src_path =~ /$compress_excl/) ){ if( $dest_path !~ /$squished/ ){ if( $src_type{ "$src_path.Z" } eq 'f' ){ # There is a compessed version # too! Skip the uncompress one print " do not xfer, compressed version exists: $src_path\n" if( $debug > 1 ); next; } if( ! $get_file ){ print " compression on sending files not yet available\n"; } else { $compress = 1; $dest_path .= '.Z'; } } } # Should I split it up? local( $split ) = 0; local( $dest_path_real ); if( $split_max && $src_type{ $src_path } eq 'f' && $src_size{ $src_path } > $split_max && $split_patt && $src_path =~ /$split_patt/ ){ $split = 1; $dest_path_real = $dest_path; $dest_path .= "-split/part01"; } if( $debug > 2 ){ print " dest $dest_path: $dest_time{ $dest_path }"; print " $dest_size{ $dest_path } $dest_type{ $dest_path }"; # print " (compress)" if( $compress ); # print " (split)" if( $split ); print "\n"; } if( $name_mappings ){ local( $old_dest_path ) = $dest_path; eval "\$dest_path =~ $name_mappings"; if( $dest_path ne $old_dest_path && $debug > 2 ){ print " Mapped name is $dest_path\n"; } } if( $get_patt && $src_path !~ /$get_patt/ ){ print " do not xfer: $src_path\n" if( $debug > 1 ); next; } if( $exclude_patt && $src_path =~ /$exclude_patt/ ){ print " exclude: $src_path\n" if( $debug > 1 ); next; } # Just create any needed directories (the timestamps # should be ignored) if( $src_type{ $src_path } eq 'd' ){ if( $dest_type{ $dest_path } ne 'd' ){ push( @things_to_make, "d $dest_path" ); print " need to mkdir $dest_path\n" if( $debug > 1 ); } next; } # Well that just leaves files and symlinks. # Do various checks on them. if( $max_age && $src_time{ $src_path } < $max_age ){ print " too old: $src_path\n" if( $debug > 1 ); next; } local( $update ) = 0; if( $force || ! $dest_type{ $dest_path } ){ # Either I'm forcing xfers or the file doesn't exist # either way I should update $update = 1; } else { # Maybe the src is newer? if( $get_newer && &compare_times( $src_time{ $src_path }, $dest_time{ $dest_path } ) ){ print " src is newer, xfer it\n" if( $debug > 2 ); $update = 1; } # or maybe its size has changed? # don't bother if file was compressed or split as the # size will have changed anyway if( !$compress && !$split && $get_size_change && ($src_size{ $src_path } != $dest_size{ $dest_path }) ){ print " src is different size, xfer it\n" if( $debug > 2 ); $update = 1; } } if( ! $update ){ next; } if( $src_type{ $src_path } =~ /^l (.*)/ ){ # DONT FORGET TO NAME MAP!!!! local( $existing_path ) = $1; push( @things_to_make, "l $dest_path -> $existing_path" ); print " need to symlink $dest_path -> $existing_path\n" if( $debug > 2 ); next; } # Now that the tests are complete use the real dest. if( defined( $dest_path_real ) ){ $dest_path = $dest_path_real; } print "$XFER file $src_path as $dest_path" . ($compress ? " (compress)" : "") . ($split ? " (split)" : "") . "\n" if( $debug > 1 ); push( @xfer_dest, $dest_path ); push( @xfer_src, $src_path ); # If xfers can be restarted AND # a temporary file exists from a previous attempt at a # transfer AND # the timestamps of the exising temp file and the original # src file match then flag a restart. local( $tmp ) = &filename_to_tempname( '', $dest_path ); local( $restart ) = ''; #print `pwd`; #print " $tmp $get_file, $can_restart, " . ((-f $tmp) ? "has size " : "no size ") . "$dest_time{ $tmp }, $src_time{ $src_path }\n"; if( $get_file && $can_restart && -f $tmp && ($dest_time{ $tmp } eq $src_time{ $src_path }) ){ # Then this is an xfer of the same file # so just restart where I left off $restart = 'r'; } # x for xfer, c for compress, s for split push( @xfer_attribs, "x$restart" . ($compress ? "c" : "") . ($split ? "s" : "") ); } } sub compare_dirs_for_deletes { local( *src_paths, *src_type, *dest_paths, *dest_type ) = @_; local( $src_path, $dest_path, $dest_index, $i ); @delete_dirs = @delete_files = (); print "compare directories for deletions\n"; for( $i = 0; $i <= $#src_paths; $i++ ){ $dest_path = $src_path = $src_paths[ $i ]; if( $debug > 2 ){ print "Compare src $src_path: $src_type{ $src_path }\n"; print " dest $dest_path: $dest_type{ $dest_path }\n"; } if( $name_mappings ){ local( $old_dest_path ) = $dest_path; eval "\$dest_path =~ $name_mappings"; if( $dest_path ne $old_dest_path && $debug > 2 ){ print " Mapped name is $dest_path\n"; } } if( $delete_excl && $src_path =~ /$delete_excl/ ){ next; } # Should exist so don't delete if( $dest_type{ $dest_path } ){ next; } # Was it compressed when xfered? Hard to tell so # just check for an uncompressed file as well. if( $dest_path =~ /$squished/ ){ local( $uncomp ) = $dest_path; $uncomp =~ s/$squished//; if( $dest_type{ $uncomp } ){ next; } } # Was it split? Really hard to tell so try and # convert back to its (probable) original name and # compare that if( $dest_path =~ /-split\/(part\d\d|README)$/ ){ local( $unsplit ) = $dest_path; $unsplit =~ s,-split/(part\d\d|README)$,,; if( $dest_type{ $unsplit } ){ next; } # Good Grief - it wasn't compressed as well if( $unsplit =~ /$squished/ ){ local( $uncomp ) = $unsplit; $uncomp =~ s/$squished//; if( $dest_type{ $uncomp } ){ next; } } } # and of course it may be a directory containing the split # up stuff! if( $dest_path =~ /-split\/$/ ){ local( $unsplit ) = $dest_path; $unsplit =~ s,-split/$,,; if( $dest_type{ $unsplit } ){ next; } # Good Grief - it wasn't compressed as well if( $unsplit =~ /$squished/ ){ local( $uncomp ) = $unsplit; $uncomp =~ s/$squished//; if( $dest_type{ $uncomp } ){ next; } } } if( $src_type{ $src_path } eq 'd' ){ push( @delete_dirs, $src_path ); print "delete dir $src_path\n" if( $debug > 1 ); } else { push( @delete_files, $src_path ); print "delete $src_path\n" if( $debug > 1 ); } } } sub set_timestamps { local( $src_path ); if( ! $get_file ){ print "Cannot set remote timestamps\n"; return; } foreach $src_path ( @xfer_src ){ local( $dest_path ); $dest_path = shift( @xfer_dest ); local( $rtime ) = $remote_time{ $src_path }; if( $local_type{ $dest_path } && $local_time{ $dest_path } ne $rtime ){ &set_timestamp( $dest_path, $rtime ); } } } sub set_timestamp { local( $path, $time ) = @_; if( $dont_do ){ print "Should set time of $path to $time\n"; return; } if( $timestamp || $debug > 2 ){ print "Setting time of $path to $time\n"; } utime( $time, $time, $path ); } sub make_things { local( $thing ); foreach $thing ( @things_to_make ){ if( $thing =~ /^d (.*)/ ){ if( ! $dont_do ){ &mkdirs( $1 ); } } elsif( $thing =~ /^l (.*) -> (.*)/ ){ if( ! $dont_do ){ &mksymlink( $1, $2 ); } } } } sub do_all_transfers { local( $src_path ); if( $#xfer_src < 0 ){ print "No files to transfer\n"; return; } foreach $src_path ( @xfer_src ){ local( $dest_path, $attribs ); $dest_path = shift( @xfer_dest ); $attribs = shift( @xfer_attribs ); if( $dont_do ){ # Skip trying to get the file. next; } print "Need to $XFER file $src_path as $dest_path ($attribs)\n" if( $debug > 1 ); print "transferring $src_path "; local( $newpath ) = &transfer_file( $src_path, $dest_path, $attribs, $remote_time{ $src_path } ); if( $get_file && $newpath eq '' ){ print "Failed to $XFER file $ftp'response\n"; if( $ftp'fatalerror ){ print "Fatal error talking to site, skipping rest of transfers\n"; &disconnect(); return; } next; } # File will now have been split up. if( $attribs =~ /s/ ){ print "\n"; next; } if( $newpath ne $src_path ){ print "into $newpath"; } print "\n"; &set_attribs( $newpath, 'f' ); # we can only force time for local files if( $force_times && $get_file ){ &set_timestamp( $newpath, $remote_time{ $src_path } ); } } } sub transfer_file { local( $src_path, $dest_path, $attribs, $timestamp ) = @_; local( $dir, $file, $temp, $compress, $split, $restart, $mesg, $got_mesg ); # Make sure the required directory exists $dir = ""; if( $dest_path =~ /^(.+\/)([^\/]+)$/ ){ ($dir, $file) = ($1, $2); if( $dest_type{ $dir } ne 'd' && &mkdirs( $dir ) ){ push( @log, "Created dir $dir\n" ); } } else { $file = $dest_path; } $temp = &filename_to_tempname( $dir, $file ); # Interpret the attrib characters if( $attribs !~ /x/ ){ # Not an xfer! return ''; } if( $attribs =~ /c/ ){ $compress = 1; $mesg = " and compress"; } if( $attribs =~ /s/ ){ $split = 1; $mesg = " and split"; } if( $attribs =~ /r/ ){ $restart = 1; } if( ! $get_file ){ # put the file remotely if( ! &ftp'put( $src_path, $temp, $restart ) ){ push( @log, "Failed to put $src_path: $ftp'response\n" ); return ''; } if( ! &ftp'rename( $temp, $dest_path ) ){ push( @log, "Failed to remote rename $temp to $dest_path: $ftp'response\n" ); return ''; } return $dest_path; } # Get a file # if( -r $temp ){ # unlink( $temp ); # } if( ! &ftp'get( $src_path, $temp, $restart ) ){ push( @log, "Failed to get $src_path: $ftp'response\n" ); # Time stamp the temp file to allow for a restart if( -f $temp ){ utime( $timestamp, $timestamp, $temp ); } return ''; } # delete source file after successfull transter if( $delete_source ){ if( &ftp'delete( $path ) ){ push( @log, "Deleted remote $lpath\n"); } else { push( @log, "Failed to delete remote $lpath\n"); print "Failed to delete remote $lpath\n"; } } # Try and compress the file - dont worry if it doesn't manage # it - the file is probably already compressed if( $compress ){ # Prevent the shell from expanding characters local( $f ) = $temp; $f =~ s/'/\\'/g; &sys( "$compress_prog '$temp'" ); if( -r "$temp.Z" ){ $temp .= '.Z'; } $got_mesg .= "and compressed"; } # Ok - chop it up into bits! if( $split ){ local( $time ) = 0; if( $force_times ){ $time = $remote_time{ $src_path }; } &bsplit( $temp, $dest_path, $time ); unlink $temp; $got_mesg .= "and split"; } else { rename( $temp, $dest_path ); } local( $filesize ) = &filesize( $dest_path ); push( @log, "Got $src_path as $dest_path $got_mesg $filesize\n" ); &log_upload( $src_path, $dest_path, $got_mesg, $filesize ); return( $dest_path ); } sub filename_to_tempname { local( $dir, $file ) = @_; # dir return "$dir.in.$file."; } # Open, write, close - to try and ensure that the log will allways be filled # in. sub log_upload { local( $src_path, $dest_path, $got_mesg, $size ) = @_; if( ! $upload_log ){ return; } if( ! open( ulog, ">>$upload_log" ) ){ print STDERR "Cannot write to $upload_log\n"; return; } print ulog "$site:$remote_dir/$src_path -> $local_dir/$dest_path $size "; if( $got_mesg ){ print ulog "($got_mesg)"; } print ulog "\n"; close( ulog ); } sub do_deletes { if( $dont_do || ! $do_deletes ){ return; } if( ! $really_do_deletes ){ print "To chicken to implement do_deletes\n"; } local( $del ); foreach $del ( @delete_files ){ if( $really_do_deletes ){ if( $get_file ){ print "unlink $cwd/$del\n"; unlink( "$cwd/$del" ); } else { &ftp'delete( "$cwd/$del" ); } } else { if( $get_file ){ print "NEED TO unlink $cwd/$del\n"; } else { print "NEED TO ftp'delete $del\n"; } } } foreach $del ( @delete_dirs ){ $del =~ s,/+$,,; if( $really_do_deletes ){ if( $get_file ){ print "rmdir $cwd/$del\n"; rmdir( "$cwd/$del" ); } else { print "Cannot delete remote directories\n"; } } else { if( $get_file ){ print "NEED TO rmdir $cwd/$del\n"; } else { print "NEED TO ftp'deldir $del\n"; } } } } sub filesize { local( $fname ) = @_; if( ! -f $fname ){ return -1; } return (stat( _ ))[ 7 ]; } # Is the value sub istrue { local( $val ) = @_; return $val eq '1' || $val eq 'yes' || $val eq 'ok' || $val eq 'true'; } sub mksymlink { local( $dest_path, $existing_path ) = @_; if( ! $get_file ){ print "Cannot create symlinks on remote systems ($dest_path -> $existing_path)\n"; return; } # make the symlink locally # Zap any exiting thing of that name if( -e $dest_path ){ unlink( $dest_path ); print "unlink( $dest_path )\n" if( $debug > 2 ); } if( (eval 'symlink("","")', $@ eq '') ){ symlink( $existing_path, $dest_path ); push( @log, "Created symlink $dest_path -> $existing_path\n" ); print "symlink( $existing_path, $dest_path )\n" if( $debug > 2 ); } else { print "Tried to create symlink - but not supported locally\n"; } } # Make a full directory heirarchy # returns true if the directory doesn't exist sub mkdirs { local( $dir ) = @_; local( @dir, $d, $path ); # Very often the directory does exist - so return now return 0 if( &dir_exists( $dir ) ); # Make sure that the target directory exists @dirs = split( '/', $dir ); # the root directory always exists $path = ''; if( $dirs[ 0 ] eq '' ) { shift( @dirs ); $path = '/'; } foreach $d ( @dirs ){ $path = $path . $d; if( ! &dir_exists( $path ) ){ print "mkdir $path\n" if( $debug > 2 ); if( ! &make_dir( $path, 0755 ) ){ print "make_dir($path,0755) failed with $err\n"; } &set_attribs( $path, 'd' ); } $path .= "/"; } return 1; } # return 0 on error, 1 on success sub make_dir { local( $dir, $mode ) = @_; local( $val ); if( $get_file ){ # make a local directory $val = mkdir( $dir, $mode ); $err = "$!"; } else { # make a remote directory $val = &ftp'mkdir( $dir ); # The mkdir might have failed due to bad mode # So try to chmod it anyway if( $remote_has_chmod ){ $val = &ftp'chmod( $dir, $mode ); } } return $val; } # return 1 if $dir exists, 0 if not sub dir_exists { local( $dir ) = @_; local( $val ); if( $get_file ){ # check if local directory exists $val = (-d $dir); } else { # check if remote directory exists local($old_dir) = &ftp'pwd(); $val = &ftp'cwd($dir); # go back to the original directory &ftp'cwd($old_dir) || die "Cannot cd to original remote directory"; } return $val; } # Set file/directory attributes sub set_attribs { local( $path, $type ) = @_; local( $mode ); if( $get_file ){ $mode = $remote_mode{ $path }; } else { $mode = $local_mode{ $path }; } # If I can't figure out the mode or I'm not copying it # use the default if( !$mode_copy || !$mode ){ if( $type eq 'f' ){ $mode = $file_mode; } elsif( $type eq 'd' ){ $mode = $dir_mode; } } # Convert from octal $mode = oct( $mode ) if( $mode =~ /^0/ ); if( $get_file ){ # Change local chmod $mode, $path; if( $user ne '' && $group ne '' ){ if( $user =~ /^\d+$/ && $group =~ /\d+$/ ){ chown $user, $group, $path; } else { if( $chowngrp ){ &sys( "$chowngrp $user.$group $path" ); } else { &sys( "$chown $user $path" ); &sys( "$chgrp $group $path" ); } } } } else { # change the remote file if( $remote_has_chmod ) { &ftp'chmod( $path, $mode ); } } } sub get_passwd { local( $user ) = @_; local( $pass ); # prompt for a password $SIG{ 'INT' } = 'IGNORE'; $SIG{ 'QUIT' } = 'IGNORE'; system "stty -echo /dev/tty 2>&1"; print "Password for $user: "; $pass = ; print "\n"; chop( $pass ); system "stty echo /dev/tty 2>&1"; $SIG{ 'INT' } = 'DEFAULT'; $SIG{ 'QUIT' } = 'DEFAULT'; return $pass; } sub compare_times { # Try and allow for time zone changes (eg when a site # switches from daylight saving to non daylight saving) # by ignoring differences of exactly one hour local( $t1, $t2 ) = @_; local( $diff ) = ($t1 > $t2 ? $t1 - $t2 : $t2 - $t1); return ($t1 > $t2) && ($diff != 3600); } sub create_assocs { local( $map ); &delete_assocs(); foreach $map ( @assocs ){ eval "\$$map = \"\$tmp/$map.$$\""; eval "dbmopen( $map, \$$map, 0644 )"; } } sub delete_assocs { local( $map ); foreach $map ( @assocs ){ eval "\$$map = \"\$tmp/$map.$$\""; &unlink_dbm( eval "\$$map" ); eval "\%$map = ()"; } } sub unlink_dbm { local( $file ) = @_; unlink "$file.pag"; unlink "$file.dir"; } # Chop the tmp file up sub bsplit { local( $temp, $dest_path, $time ) = @_; local( $dest_dir ) = "$dest_path-split"; local( $bufsiz ) = 512; local( $buffer, $in, $sofar ); print "Splitting up $temp into $dest_dir/ ($time)\n" if( $debug ); # Stomp on the original directories &sys( "$rm_prog $dest_dir" ); &mkdirs( $dest_dir ); local( $index ) = "00"; local( $part ); open( tmp, $temp ) || die "Cannot open $temp!"; $sofar = $split_chunk; # Force a new file while( ($in = sysread( tmp, $buffer, $bufsiz )) > 0 ){ if( $sofar >= $split_chunk ){ if( $part ){ close( part ); if( $time ){ &set_timestamp( $part, $time ); } } $index++; $part = "$dest_dir/part$index"; print "creating $part\n" if( $debug ); open( part, ">$part" ) || die "Cannot create $part"; $sofar = 0; } if( ($out = syswrite( part, $buffer, $in )) != $in ){ die "Failed to write data to $part"; } $sofar += $in; } close( part ); if( $time ){ &set_timestamp( $part, $time ); } close( tmp ); # Generate a readme file about what is in the split directory local( $readme ) = "$dest_dir/README"; open( readme, ">$readme" ) || die "Cannot create $readme"; print readme "This directory contains a splitup version of $dest_path\n"; print readme "to recreate the original simply concatenate all the\n"; print readme "parts back together.\n\nChecksums are:\n\n"; close readme; &sys( "(cd $dest_dir ; $sum_prog part* ) >> $readme" ); } sub sys { local( $com ) = @_; print "$com\n" if( $debug > 2 ); system( $com ); } # Set up an associative array given all an array of keys. # @fred = ( 'a' ); # &set_assoc_from_array( *fred ) # Creates => $fred{ 'a' } = 1 # sub set_assoc_from_array { local( *things ) = @_; foreach $thing ( @things ){ $things{ $thing } = 1; } } # Scan the given directory and all all files in it to the list # of config files sub add_all_files { local( $dir ) = @_; chdir( $dir ) || die "Cannot chdir to $dir"; opendir( dir, '.' ) || die "Cannot scan $dir"; foreach $file ( readdir( dir ) ){ if( -f $file ){ push( @config_files, "$dir/$file" ); } } closedir( dir ); chdir $home; }