#!/usr/local/bin/perl
;#
;# Copyright (c) 1995-1997
;#	Ikuo Nakagawa.  All rights reserved.
;#
;# $Id: ftpmirror,v 1.46 1997/06/08 05:10:43 ikuo Exp $
;#
;# Name:
;#	ftpmirror
;# Version:
;#	1.2k
;# Author:
;#	Ikuo Nakagawa <ikuo@intec.co.jp>
;# Last update:
;#	1997/06/08
;# History:
;#	1997/06/08 Fix a bug of "rmdir: no such file..." in remove.
;#	1997/06/07 Fix a ignorance of linkto differences in compare.
;#	1997/06/02 $ifoverride was removed from fileowner/filemode.
;#	1997/06/02 -x in &filemode was changed to -d.
;#	1997/06/01 Fix a bug of &retr in ftputil.pl.
;#	1997/06/01 Fix &compare to see time diff in case of no MDTM.
;#	1997/05/22 parse-realpath was added for get_remote_list.
;#	1997/05/21 symlink-map was added for substitute symlink value.
;#	1997/05/21 realpath and reallinkto keys were added.
;#	1997/05/21 Fix a bug of symlink trouble if $change-directory = 1.
;#	1997/05/20 $follow-symlink-regexp was added.
;#	1997/04/01 Now, ftpmirror checks negative modified time.
;#	1997/01/27 Add test of `-l $dir' in get_local_list.
;#	1996/12/13 defined($p->{..}) were used in fileowner/filemode.
;#	1996/12/04 $tmplslR must have temporary filename.
;#	1996/11/26 ftpmirror-1.2 was released.
;#	1996/11/19 Temporary files were not removed. Fix $tmplslR.
;#	1996/11/19 Some information should be logged as NOTICE message.
;#	1996/11/05 Let bad offset be ignored, and offset log be INFO log.
;#	1996/10/28 You can define unlink-limit as 30M, 2G or 100(# of files).
;#	1996/10/28 Ignore '.' or '..' in check_limit.
;#	1996/10/24 New paramter alternate-package/load-package were added.
;#	1995/10/24 Round Robin in DNS was supported.
;#	1996/10/21 Unlink lslR-file after mirror session.
;#	1996/10/19 Check size/modifed once more, before real transfer.
;#	1996/10/19 Compare filenames before caching in ls-lR parse.
;#	1996/10/18 Path information was added in dirinfo.
;#	1996/10/18 Reduce max use memory in ls-lR parsing.
;#	1996/10/17 Override mode/owner if override-* was specified.
;#	1996/10/17 Do *NOT* chown if effictive uid is not 0.
;#	1996/10/16 Possible to expand IDLE timer with ftp-max-idle.
;#	1996/10/09 Fix a bug in *-regexp search algorithm.
;#	1996/10/09 Prototypes were commented out.
;#	1996/09/29 Unlink old file before symlink.
;#	1996/09/25 Beta release of ftpmirror-1.2.
;#	1996/09/23 Reduce indents for readability.
;#	1996/09/21 Some parameters for ls-lR parsing were added.
;#	1996/09/20 Set hostname to be "localhost" if hostname failed.
;#	1996/09/20 pack_sin/unpack_sin were added in ftputil.pl.
;#	1996/09/20 Fix typo of ``symlink'' in dirinfo.pl.
;#	1996/09/19 Parsing ls-lR was supported.
;#	1996/09/16 lsparse.pl was created.
;#	1996/09/16 Logging of local/remote file information was changed.
;#	1996/09/15 Use putl(in log.pl) to put log lines.
;#	1996/09/11 Use puts(in log.pl) rather than log(in Log.pm).
;#	1996/09/11 Try to check a slash `/' for directory entries.
;#	1996/09/10 Try to generate/use directory information.
;#	1996/09/06 Separate regexp into *-directory and *-file.
;#	1996/09/03 param.pl was splitted out, $param was obsoleted.
;#	1996/08/07 Some changes for readability, use `qw' or others.
;#	1996/07/31 change-directory parameter was added.
;#	1996/05/25 Rewrite main loop.
;#	1996/03/21 Support DOS dirstyle in NT servers.
;#	1996/03/12 Fix around pack_sockaddr_in for perl5.002.
;#	1996/03/10 Release of version 1.1.
;#	1996/03/02 Fix some lines for perl -w checking.
;#	1996/02/24 Lock when mirroring a package.
;#	1996/02/14 ftp-gateway is supported for ftp proxy.
;#	1996/02/12 ftp-login takes no argument. Use $ftp::* otherwise.
;#	1996/02/11 Checking with `perl -w' to aboid bugs ;-)
;#	1996/02/10 Add server parameters.
;#	1996/01/24 Send LIST when directory STAT failed.
;#	1996/01/11 Add override-regexp parameter for local files.
;#	1996/01/10 Fix bug in &remove, use lstat to test symlink.
;#	1995/12/31 Support multiple packages in one config file.
;#	1995/12/04 Support pack_sockaddr_in in perl5.001n.
;#	1995/11/09 Now, we sort directory list from server. (For NT server)
;#	1995/11/09 Fix `file_gid' to `file-gid' for $param key.
;#	1995/11/07 Date string sent by NT server is supported.
;#	1995/11/03 A line 'total nnn' isn't required for NT server.
;#	1995/10/22 Add home-directory parameter.
;#	1995/10/21 BUG fix in $offset and $param_config.
;#	1995/10/13 Add test-mode for no-transfer mirroring.
;#	1995/08/05 Add remote-timezone parameter to adjust STAT time.
;#	1995/07/30 Add compare-stat parameter to select STAT or SIZE/MDTM.
;#	1995/07/11 Code for compare using STAT rather than SIZE/MDTM.
;#	1995/07/10 Using STAT to get a directory status.
;#	1995/07/03 Use null address to bind a socket.
;#	1995/06/16 Add rename code in remove subroutine.
;#	1995/06/15 Ignore '.' and '..' in LIST's result.
;#	1995/06/14 Add mode evaluation for file-mode, symlink-mode, etc.
;#	1995/05/07 First edition.
;# Comments:
;#	There are some global parameter:
;#	  $prefix : a directory which contains ftpmirror utilities.
;#	  $package : current package name to mirror.
;#	  $loglevel : a parameter which defines the level of logggin.
;#	  $dirinfo : a filename which contains directory information.
;#	  $p : a reference to a HASH of package specific parameters.
;#

;# IMPORTANT: change to the package directory
$prefix = '/usr/local/lib/ftpmirror';

;# Some special filenames
$dirinfo = ".dirinfo";

;# Setup required files before real work
unshift(@INC, $prefix);
require 'log.pl';
require 'timelocal.pl';
require 'lsparse.pl';
require 'param.pl';
require 'ftputil.pl';
require 'shlock.pl';
require 'dirinfo.pl';

;# We use strict mode for variable check.
use strict;
use vars qw($p $program @nameofmonth %tempfiles $package $dirinfo);

;# Prototypes for perl5.003 or later
;# sub usage();
;# sub date();
;# sub abort();
;# sub validfile($);
;# sub mkdirhier($);
;# sub lookup($;$);
;# sub fileowner($;$);
;# sub filemode($;$);
;# sub remove($;$);
;# sub del_local_file($);
;# sub del_remote_file($);
;# sub del_local_directory($);
;# sub del_remote_directory($);
;# sub get_link($$);
;# sub get_file($);
;# sub put_link($$);
;# sub put_file($);
;# sub get_local_list($);
;# sub get_remote_list($);
;# sub walk($);
;# sub compare($$);
;# sub retrieve($$);
;# sub issame($$$);
;# sub mirror($);

;# Save this program name to $program
($program) = ($0 =~ m%([^/]+)$%);

;# to catch up any errors and debug informations
$SIG{'__DIE__'} = \&abort;
$SIG{'INT'} = \&abort;
$SIG{'QUIT'} = \&abort;
$SIG{'TERM'} = \&abort;

;# NON-blocking STDOUT
$| = 1;

;# names of month, and conversion table
@nameofmonth = qw(Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec);
;# @nametomonth{map(lc $_, @nameofmonth)} = (0..11);
;# $regexp_month = join('|', @nameofmonth);

;# set initial values (initial, options, default)
param::init(*ARGV) || die "Can't set initial parameters.\n";

;# dump parameters
;# &param::dumpall;

;# parsing target configuration
while (@ARGV) {

 ;# save current package name
 $package = shift;

 ;# clear label for logging
# log::label($package);

 ;# find configuration and merge parameters
 defined($p = param::load($package))
  || do { log::putl("WARNING", "package \"$package\" not found."), next };

 ;# checking parameters - this is required for setup some ftp parameters
 param::check($p)
  || do { log::putl("WARNING", "$package: parameter check failed."), next };

 ;# set logging priority
 log::mask($p->{'log-priority'});
 log::label($p->{'log-label'}) if defined($p->{'log-label'});

 ;# initial log
 log::putl("NOTICE", "package $package started at ".&date);

 if ($p->{'log-priority'} > log::level("INFO")) {
  log::putl("DEBUG", "dump initial parameters.");
  param::dump($p);
 }

 ;# declare my variable $LOCK
 my $LOCK;

 ;# lock this package
 if (!$p->{'test-mode'}) {
  ($LOCK = $package) =~ s,/,#,g;
  $LOCK = "$p->{'lock-directory'}/LOCK.$LOCK";
  $tempfiles{$LOCK} = 1;
  if (!&shlock($LOCK)) {
   log::putl("WARNING", "can't lock the package."), next;
  }
 }

 ;# ok. now go to mirror
 if (!&mirror($p)) {
  if ($p->{'alternate-package'} ne '') {
   log::putl("WARNING", "mirroring terminated abnormally, try alternate.");
   unshift(@ARGV, $p->{'alternate-package'});
  } else {
   log::putl("WARNING", "mirroring terminated abnormally, skip this package.");
  }
 }

 ;# unlock this package, only unlink LOCK file
 unlink($LOCK), delete($tempfiles{$LOCK}) if !$p->{'test-mode'};

 ;# final
 log::putl("NOTICE", "package $package done at ".&date);
}

;# normal termination
exit;

;# print usage and exit
sub usage {
 die "Usage: $program [options] package ...\n";
}

;#
sub date {
 my @xx = reverse((localtime)[0..5]);

 $xx[0] += 1900; $xx[1]++;
 sprintf("%04d-%02d-%02d %02d:%02d:%02d", @xx);
}

;#
sub abort {
 my($i);

 for (keys %tempfiles) { # clean files
  print STDERR "unlink $_\n";
  unlink($_);
 }

 print STDERR @_;
 while (caller($i)) { # for DEBUG
  print STDERR join(', ', caller($i++))."\n";
 }
 exit 255;
}

;#
sub validfile {
 my($x) = @_;

 $x eq '' || $x eq '.' || $x eq '..' || $x =~ /\// ? 0 : 1;
}

;# create intermediate directories as required
sub mkdirhier {
 local($_) = @_;

 my $d = s%^/+%% ? '' : '.';
 for (split('/')) {
  -d ($d .= '/'.$_) && next;
  unlink($d); # ignore result
  mkdir($d, 0755)
   || do { log::putl("WARNING", "mkdir($d): $!"), return undef };
 }
 1;
}

;# lookup a pathname
sub lookup {
 local($_) = @_;
 my $tmp;

 return "." if $_ eq '' || $_ eq '.';
 $_ .= '/';			# add trailing slash
 s|/+|/|go;			# foo//bar -> foo/bar
 my $absolute = s|^/||;		# 1 if $_ is a absolute path
 $_ = '/'.$_;			# for convinience
 1 while s|/\./|/|go;		# foo/./bar -> foo/bar
 do {				# xyz/foo/../bar -> xyz/bar
  $tmp = $_;
  s|([^/]+)/\.\./|$1 eq '..' ? '../../' : ''|geo;
 } while ($tmp ne $_) ;
 s|^/|| if !$absolute;
 s|/+$|| if $_ ne '/';
 $_ = '.' if $_ eq '';
 $_;
}

;#
sub fileowner {
 my($path, $x) = @_;
 my($ouid, $ogid) = (stat($path))[4, 5];

 ;# only the superuser can change owner
 return 0 if $>;

 ;# set owner and group ids
 my $uid = undef;
 if (defined($p->{'override-file-uid'})) {
  $uid = $p->{'override-file-uid'};
  $uid = getpwnam($uid) if $uid !~ /^\d+$/;
 }
 if (!defined($uid) && defined($x) && defined($x->{'owner'})) {
  my $u;
  if (defined($u = getpwnam($x->{'owner'}))) {
   $uid = $u;
  }
 }
 if (!defined($uid) && defined($p->{'default-file-uid'})) {
  $uid = $p->{'default-file-uid'};
  $uid = getpwnam($uid) if $uid !~ /^\d+$/;
 }

 my $gid = undef;
 if (defined($p->{'override-file-gid'})) {
  $gid = $p->{'override-file-gid'};
  $gid = getgrnam($gid) if $gid !~ /^\d+$/;
 }
 if (!defined($gid) && defined($x) && defined($x->{'group'})) {
  my $g;
  if (defined($g = getgrnam($x->{'group'}))) {
   $gid = $g;
  }
 }
 if (!defined($gid) && defined($p->{'default-file-gid'})) {
  $gid = $p->{'default-file-gid'};
  $gid = getgrnam($gid) if $gid !~ /^\d+$/;
 }
 if (!defined($gid)) {
  $gid = $ogid if defined($ogid);
 }
 # call chown!
 if (defined($uid) && defined($gid)) {
  if ($ouid != $uid || $ogid != $gid) {
   log::puts("INFO", "* $path ... change owner to $uid.$gid");
   if (chown($uid, $gid, $path)) {
    log::putl("INFO", " ok");
    return 1;
   }
   log::puts("INFO", " failed");
  } else {
   log::putl("DEBUG", "* $path ... no need to change owner");
  }
 } else {
  log::putl("INFO", "* $path ... can't define owner, ignored");
 }
 0;
}

;#
sub filemode {
 my($path, $x) = @_;

 my $t = -d $path ? 'directory' : 'file';

 my $mode = undef;
 if (defined($p->{"override-$t-mode"})) {
  $mode = $p->{"override-$t-mode"};
 }
 if (!defined($mode) && defined($x) && defined($x->{'mode'})) {
  $mode = $x->{'mode'};
 }
 if (!defined($mode) && defined($p->{"default-$t-mode"})) {
  $mode = $p->{"default-$t-mode"};
 }
 if (defined($mode)) {
  eval "\$mode = $mode & 0777";
  die $@ if $@;
  if (((stat($path))[2] & 0777) != $mode) {
   log::puts("INFO", "* $path ... change file mode");
   if (chmod($mode, $path)) {
    log::putl("INFO", " ok");
    return 1;
   }
   log::putl("INFO", " failed");
  } else {
   log::putl("DEBUG", "* $path ... no need to change mode");
  }
 } else {
  log::putl("INFO", "* $path ... can't define file mode");
 }
 0;
}

;#
sub check_size {
 my($path, $size) = @_;
 my $next;
 local(*DIR);

 return $size if -l $path;
 return $size - -s $path if -f $path;
 return $size if ! -d $path;

 opendir(DIR, $path) || return $size;
 while (defined($next = readdir(DIR))) {
  next if $next eq '.' || $next eq '..';
  last if ($size = &check_size("$path/$next", $size)) <= 0;
 }
 closedir(DIR);
 $size;
}

;#
sub check_num {
 my($path, $num) = @_;
 local(*DIR);
 my $next;

 return $num - 1 if -l $path || -f $path;
 return $num if ! -d $path;

 opendir(DIR, $path) || return $num;
 while (defined($next = readdir(DIR))) {
  next if $next eq '.' || $next eq '..';
  last if ($num = &check_num("$path/$next", $num)) <= 0;
 }
 closedir(DIR);
 $num;
}

;# remove file or directory
;#   second argument means:
;#	2 - remove force
;#	1 - rename pathname to pathname~
;#	0 - default (depend on $p->{'unlink-type'})
sub remove {
 my($y, $type) = @_;
 my $x;
 local(*DIR);

 ;# check the file first - don't follow symlink
 return 0 if $y eq '.' || $y eq '..' || !lstat($y);

 ;# check remove type
 $type = $p->{'unlink-type'} if !defined($type);

 ;# check parameters and others
 if ($type == 0 || $type == 1 && $y =~ /$p->{'backup-suffix'}$/) {
  log::putl("INFO", "* $y ... remove(ignore)");
  return 0;
 }

 ;# check unlink-limit
 if ($p->{'unlink-limit'} > 0) {
  my $val = $p->{'unlink-limit'};
  my $size;
  if ($val =~ /^\d+$/) {
   my $num = $&;
   if (&check_num($y, $num) <= 0) {
    log::putl("NOTICE", "* $y ... remote(too many, ignore)");
    return 0;
   }
  } else {
   if ($val =~ /^(\d+)b$/i) {
    $size = $1;
   } elsif ($val =~ /^(\d+)kb?$/i) {
    $size = $1 * 1024;
   } elsif ($val =~ /^(\d+)mb?$/i) {
    $size = $1 * 1024 * 1024;
   } elsif ($val =~ /^(\d+)gb?$/i) {
    $size = $1 * 1024 * 1024 * 1024;
   } else {
    log::putl("NOTICE", "* $y ... remove(bad unlink-limit, ignore)");
    return 0;
   }
   if (&check_limit($y, $size) <= 0) {
    log::putl("INFO", "* $y ... remove(too big, ignore)");
    return 0;
   }
  }
 }

 ;# rename rather than unlink?
 if ($type == 1) {
  $x = $y.$p->{'backup-suffix'};
  log::puts("NOTICE", "* $y ... remove(rename)");
  if ($p->{'test-mode'}) {
   log::putl("NOTICE", "");
   return 1;
  } else {
   &remove($x, 2);
   if (rename($y, $x)) {
    log::putl("NOTICE", " ok"), return 1;
   } else {
    log::putl("NOTICE", ": $!"), return 0;
   }
  }
 }

 ;# remaining case means 'remove force'
 if (-l $y || ! -d $y) {
  log::puts("NOTICE", "* $y ... remove(unlink)");
  if ($p->{'test-mode'}) {
   log::putl("NOTICE", ""), return 1;
  } else {
   if (unlink($y)) {
    log::putl("NOTICE", " ok"), return 1;
   } else {
    log::putl("NOTICE", ": $!"), return 0;
   }
  }
 }

 ;# initialize counter
 my $count = 0;

 ;# target is a directory
 opendir(DIR, $y)
  || do { log::putl("WARNING", "opendir($y): $!"), return undef };
 while (defined($x = readdir(DIR))) {
  $count += &remove("$y/$x", $type) if $x ne '.' && $x ne '..';
 }
 closedir(DIR);

 ;# remove this directory
 log::puts("NOTICE", "* $y/ ... remove(rmdir)");
 if ($p->{'test-mode'}) {
  log::putl("NOTICE", ""), return ++$count;
 } else {
  if (rmdir($y)) {
   log::putl("NOTICE", " ok"), return ++$count;
  } else {
   log::putl("NOTICE", ": $!"), return $count;
  }
 }
}

;#
sub del_local_file {
 my($x) = @_;

 if (!&{$p->{'override-file'}}($x)) {
  log::putl("INFO", "* $x ... ignored by override-file"), return;
 }
 &remove($x);
}

;#
sub del_remote_file {
 my($x) = @_;

 log::putl("INFO", "DEL REMOTE $x ... not implemented.");
 0;
}

;#
sub del_local_directory {
 my($x) = @_;

 if (!&{$p->{'override-directory'}}("$x/")) {
  log::putl("INFO", "* $x/ ... ignored by override-directory"), return;
 }
 &remove($x);
}

;#
sub del_remote_directory {
 my($x) = @_;

 log::putl("INFO", "DEL REMOTE $x/ ... not implemented.");
 0;
}

;#
sub get_link {
 my($x, $t) = @_;

 if (!&{$p->{'transfer-file'}}($x)) {
  log::putl("INFO", "+ $x ... ignored by transfer-file"), return 0;
 }
 if (-e $x && !&{$p->{'override-file'}}($x)) {
  log::putl("INFO", "+ $x ... ignored by override-file"), return 0;
 }
 &remove($x) if -e $x;
 log::puts("NOTICE", "* $x ... making link ");
 if ($p->{'test-mode'}) {
  log::putl("NOTICE", "creating");
 } else {
  unlink($x); # ignore result
  if (!symlink($t, $x)) {
   log::putl("WARNING", "symlink($t, $x): $!"), return 0;
  }
  log::putl("NOTICE", "done");
 }
 1;
}

;#
sub get_file {
 my($x) = @_;

 if (!&{$p->{'transfer-file'}}($x)) {
  log::putl("INFO", "+ $x ... ignored by transfer-file"), return 0;
 }
 if (-e $x && !&{$p->{'override-file'}}($x)) {
  log::putl("INFO", "+ $x ... ignored by override-file"), return 0;
 }
 &retrieve(@_);
}

;#
sub put_link {
 my($x) = @_;

 log::putl("INFO", "PUT LINK $x ... not implemented.");
 0;
}

;#
sub put_file {
 my($x) = @_;

 if (!&{$p->{'transfer-file'}}($x)) {
  log::putl("INFO", "+ $x ... ignored by transfer-file"), return 0;
 }
 if (-e $x && !&{$p->{'override-file'}}($x)) {
  log::putl("INFO", "+ $x ... ignored by override-file"), return 0;
 }
 &store(@_);
 1;
}

;#
;# Get list of local directory
;#
sub get_local_list {
 my($dir) = @_;
 my($file, @list, $ref, $tmpref);
 local($_, *DIR);

 ;# set reference to an empty assoc;
 $ref = {};

 ;# local path may be a symlink or normal file
 if (-e $dir && (-l $dir || ! -d $dir)) {
  if (!($p->{'directory-found'} && -d $dir)) { # not a directory
   &remove($dir) || return undef;
  }
 }

 ;# get a list of local directory
 if ($p->{'test-mode'}) {
  if (!($p->{'directory-found'} && -d $dir)) {
   log::putl("NOTICE", "* $dir/ ... creating");
   return $ref;
  }
 } else { # in real work
  if (! -d $dir) {
   &mkdirhier($dir) || return undef;
   return $ref;
  }
 }

 if ($p->{'load-local-dirinfo'}) {
  log::puts("INFO", "* $dir/ ... loading local dirinfo");
  if (defined($ref = &dirinfo::load_dirinfo($dir))) {
   log::putl("INFO", " ok");
   return $ref;
  }
  log::putl("INFO", " failed");
 }

 log::puts("INFO", "* $dir/ ... generating local dirinfo");
 if (defined($ref = &dirinfo::make_dirinfo($dir, 0))) {
  log::putl("INFO", " ok"), return $ref;
 }
 log::putl("INFO", " failed");
 undef;
}

;#
;# Get a list of server's directory
;#
sub get_remote_list {
 my($dir) = @_;
 my(@list, $s, $d, $r, $ref);
 my $realdir = undef;
 local $_;

 ;# if we are running with lslR-file
 return &lsparse::scan_search($dir) if $p->{'lslR-scan'};

 ;# set reference to an empty assoc;
 $ref = {};

 ;# Get update information from the server
 if ($p->{'load-remote-dirinfo'}
  && defined($_ = &ftp::stat("$dir/$dirinfo"))) {
  1 while s/^2\d\d-[^\r\n]*\r?\n//;
  s/2\d\d [^\r\n]*\r?\n$//;
  @list = split(/\r?\n/); # remote entry
  ;# If "$d/$dirinfo" is a directory, then STAT returns a list
  ;# of filenames which do NOT contains '/'. Otherwise, (e.g.
  ;# if "$d/$dirinfo" is a normal file) STAT returns a file
  ;# name just same as "$d/$dirinfo".
  if (@list && defined($s = lsparse::lsparse(shift(@list)))
   && "$dir/$dirinfo" eq $s->{'file'}) {
   my $tmpdirinfo = "$p->{'temp-directory'}/$dirinfo.$$";
   log::puts("INFO", "+ $dir/ ... retrieve dirinfo");
   if (&ftp::retr("$dir/$dirinfo", $tmpdirinfo)) {
    if (defined($r = &dirinfo::load_dirinfo($tmpdirinfo))) {
     log::putl("INFO", " done");
     unlink($tmpdirinfo);
     for $s (keys %{$r}) {
      $r->{$s}->{'path'} = "$dir/$s";
     }
     return $r;
    } else {
     log::putl("INFO", " ok, but can't parse");
    }
   } else {
    log::putl("INFO", " failed");
   }
   unlink($tmpdirinfo);
  } else {
   log::putl("INFO", "$dir/ ... can't loading remote dirinfo");
  }
 }

 ;# try to get a list of remote directory
 if ($p->{'change-directory'}) {
  if (!&ftp::cd($dir)) {
   log::putl("WARNING", "Can't go to $dir"), return undef;
  }
  $d = ".";
  if ($p->{'parse-realpath'}) {
   if (!defined($realdir = &ftp::pwd())) {
    log::putl("NOTICE", "Can't get remote directory name"), return undef;
   }
   my $tmpdir = &lookup("$p->{'remote-directory'}/$dir");
   my $n = $tmpdir =~ tr/\///;		# means # of '/' in $tmpdir.
   $realdir =~ s|^/||;
   $realdir = ('../' x $n).$realdir if $dir ne '/';
  }
 } else {
  $d = $dir;
 }

 ;# get a list of remote directory
 if ($p->{'ftp-list-method'} ne 'list'
  && defined($_ = &ftp::stat($d))) {
  1 while s/^2\d\d-[^\r\n]*\r?\n//;
  s/2\d\d [^\r\n]*\r?\n$//;
  @list = split(/\r?\n/); # remote entry
 } else { # use LIST otherwise
  if (!(@list = &ftp::list($d))) { # remote entry
   log::putl("WARNING", "Can't get list of $dir"), return undef;
  }
 }

 ;# go back to the original directory
 if ($p->{'change-directory'}) {
  if (!&ftp::cd($p->{'remote-directory'})) {
   log::putl("WARNING", "Can't go to $p->{'remote-directory'}");
   return undef;
  }
 }

 ;# ignore one more line if it begins with 'total'
 if (@list > 0 && $list[$[] =~ /^total \d+$/) {
  shift(@list); # skip first line
 }

 ;# set assoc array values
 for (@list) { # parse, check remote name, and register it
  if (!(defined($s = lsparse::lsparse($_)) &&
        defined($_ = $s->{'file'}))) {
   log::putl("DEBUG", "lsparse failed");
   next;
  }
  s/\/+$//;	# kill trailing slashes
  if (!&validfile($_)) { # and check another slashes...
   log::putl("DEBUG", "$_ ... invalid filename, ignored");
   next;
  }
  $s->{'path'} = "$dir/$_";
  if (defined($realdir)) {
   $s->{'realpath'} = &lookup("$realdir/$_");
  }
  if ($s->{'type'} eq 'symlink' &&
      (defined($realdir) || defined($p->{'symlink-subst'}))) {
   if ($s->{'linkto'} =~ /^\.\.\//) { # check only upper link
    my $tmp = defined($realdir) ?
     &lookup("$realdir/$s->{'linkto'}") : $s->{'linkto'};
    if (defined($p->{'symlink-subst'})) {
     $tmp = &{$p->{'symlink-subst'}}($tmp);
    }
    $s->{'reallinkto'} = &lookup($tmp);
#    log::putl("DEBUG", "reallinkto = $s->{'reallinkto'} ($tmp)");
   }
  }
  $ref->{$_} = $s;
 }

 ;# an entry for current directory
# $s = \%{$ref->{'.'}};
# $s->{'type'} = 'directory';
# $s->{'file'} = '.';

 ;#
 $ref;
}

;# Walk the directory
sub walk {
 my($dir) = @_;
 my($llist, $rlist);
 my(@list, $d);
 my(@le, @re, $count);
 local($_, $[, *DIR);

 ;# check transfer/override regexp
 if ($p->{'xfertype'} eq 'PUT') {
  ; # not supported
 } else { # GET
  if (0) { ## perhaps, we need not these check...
   if (!&{$p->{'transfer-directory'}}("$dir/")) {
    log::putl("INFO", "+ $dir/ ... ignored by transfer-directory");
    return undef;
   }
   if (-d $dir && !&{$p->{'override-directory'}}("$dir/")) {
    log::putl("INFO", "+ $dir/ ... ignored by override-directory");
    return undef;
   }
  } ## end-of-skip (in this version)
 }

 ;# @le is the whole list of local directory.
 if (!defined($llist) && !defined($llist = &get_local_list($dir))) {
  log::putl("WARNING", "can't get local directory list");
  return undef;
 }
 @le = sort keys %{$llist};

 ;# Get a file list of server's directory
 ;# @re is the whole list of remote directory.
 if (!defined($rlist) && !defined($rlist = &get_remote_list($dir))) {
  log::putl("WARNING", "can't get remote directory list");
  return undef;
 }
 @re = sort keys %{$rlist};

 ;# We count up updated/unlinked files
 $count = 0;

 ;# begin-update for current directory
 my $cur_begin = time;

 ;# Main loop
 while (@re || @le) {

  ;# Ignore special/illegal files
  while (@re) {
   shift(@re), next if !&validfile($re[0]);
   my $r = $rlist->{$re[0]};
   if (defined($p->{'follow-symlink-regexp'}) && $r->{'type'} eq 'symlink' &&
       &{$p->{'follow-symlink'}}($r->{'path'})) {
    if (&ftp::cd($r->{'path'})) {
     $r->{'type'} = 'directory';
     &ftp::cd($p->{'remote-directory'}); # must return success code.
    }
   }
   if ($r->{'type'} eq 'directory') {
    if (!&{$p->{'transfer-directory'}}("$r->{'path'}/")) {
     log::putl("INFO", "+ $r->{'path'}/ ... ignored by transfer-directory");
     shift(@re), next;
    }
   } elsif ($r->{'type'} eq 'file' || $r->{'type'} eq 'symlink') {
    if (!&{$p->{'transfer-file'}}($r->{'path'})) {
     log::putl("INFO", "+ $r->{'path'} ... ignored by transfer-file");
     shift(@re), next;
    }
   } else {
    shift(@re), next;
   }
   last;
  }

  ;# skip invalid files in local side
  shift(@le) while @le && !&validfile($le[0]);

  ;# Local variables
  my($re, $le, $r, $l, $action, $path);

  ;# Set remote and local entries
  ($re, $r) = ($re[0], $rlist->{$re[0]}) if @re;
  ($le, $l) = ($le[0], $llist->{$le[0]}) if @le;

  ;# Compare local and remote files
  my $comp = defined($re) && defined($le)
           ? $re cmp $le : defined($le) ? 1 : -1;

  ;#
  if ($p->{'log-priority'} > log::level("INFO")) {
   if (!defined($le)) {
    log::putl("DEBUG", "(remote = $re, comp = $comp)");
   } elsif (!defined($re)) {
    log::putl("DEBUG", "(local = $le, comp = $comp)");
   } elsif ($re eq $le) {
    log::putl("DEBUG", "(remote = local = $le, comp = $comp)");
   } else {
    log::putl("DEBUG", "(remote = $re, local = $le, comp = $comp)");
   }
  }

  ;# Check the status of compare
  if ($comp > 0) { # $le is only in local
   $action = $p->{'xfertype'} eq 'PUT' ? 'PUT' : 'DEL_LOCAL';
   $path = "$dir/$l->{'file'}";
   shift(@le);		# update in the next iteration
  } elsif ($comp < 0) { # $re is only in remote
   $action = $p->{'xfertype'} eq 'PUT' ? 'DEL_REMOTE' : 'GET';
   $path = "$dir/$r->{'file'}";
   shift(@re);		# update in the next iteration
  } else { # $le == $re are in both of local and remote
   if (&compare($l, $r)) { # but we are not sure that "they are same"
    $action = $p->{'xfertype'} eq 'PUT' ? 'PUT' : 'GET';
   } else {
    $action = 'NONE';
   }
   $path = "$dir/$l->{'file'}";
   shift(@re); shift(@le);	# update in the next iteration
  }

  ;# real action stage
  if ($action eq 'PUT') {
   if ($l->{'type'} eq 'directory') {
    $count += &walk($path);
   } elsif ($l->{'type'} eq 'symlink') {
    $count += &put_link($path, $l->{'linkto'});
   } elsif ($l->{'type'} eq 'file') {
    $count += &put_file($path, $l);
   }
  } elsif ($action eq 'GET') {
   if ($r->{'type'} eq 'directory') {
    if (!(defined($r->{'end-update'}) &&
          defined($l->{'begin-update'}) &&
          $r->{'end-update'} < $l->{'begin-update'})) {
     my($begin, $end, $c);
     $begin= time;
     $count += ($c = &walk($path));
     &fileowner($path, $r);
     &filemode($path, $r);
     $end = time;
     if ($c > 0 ||
         (defined($r->{'end-update'}) &&
          defined($l->{'begin-update'})) ||
         ($p->{'store-local-dirinfo'} &&
          !defined($l->{'begin-update'}))) {
      $l->{'begin-update'} = $begin;
      $l->{'end-update'} = $end;
     }
    } else {
     if (&fileowner($path, $r) || &filemode($path, $r)) {
      log::putl("INFO", "* $path/ ... owner/mode was changed");
      $count++;
     } else {
      log::putl("DEBUG", "* $path/ was not updated");
     }
    }
   } elsif ($r->{'type'} eq 'symlink') {
    $count += &get_link($path,
     exists($r->{'reallinkto'}) ? $r->{'reallinkto'} : $r->{'linkto'});
   } elsif ($r->{'type'} eq 'file') {
    $count += &get_file($path, $r);
   }
  } elsif ($action eq 'DEL_LOCAL') {
   if ($l->{'type'} eq 'directory') {
    $count += &del_local_directory($path);
   } else {
    $count += &del_local_file($path);
   }
  } elsif ($action eq 'DEL_REMOTE') {
   if ($r->{'type'} eq 'directory') {
    $count += &del_remote_directory($path);
   } else {
    $count += &del_remote_file($path);
   }
  } else {
   if (&fileowner($path, $r) || &filemode($path, $r)) {
    log::putl("INFO", "* $path ... owner/group was changed");
    $count++;
   } else {
    log::putl("DEBUG", "* $path was not updated");
   }
  }
 }

 ;#
 if ($count > 0) {
  my $l = \%{$llist->{'.'}};
  $l->{'type'} = 'directory';
  $l->{'file'} = '.';
  $l->{'begin-update'} = $cur_begin;
  $l->{'end-update'} = time;
 }

 ;# update local dirinfo database
 if ($p->{'store-local-dirinfo'}) {
  &dirinfo::store_dirinfo($dir, $llist); # store once
  defined($llist = &dirinfo::make_dirinfo($dir, 1)) &&
   &dirinfo::store_dirinfo($dir, $llist);
 }

 ;#
 if ($count > 0) {
  log::putl("INFO", "* $dir/ ... total $count files updated");
 } else {
  log::putl("INFO", "* $dir/ ... no change");
 }
 $count;
}

;#
;# Compair a local file and a remote file. Two arguments
;# are references to a local file structure and a remote
;# file structure.
;#
;# Checking algorithm:
;#
sub compare {
 my($l, $r) = @_;

 my($size, $date) = @_;
 my($s, $s0, $d, $x, $y, $t, $l_size, $l_time);
 my($mtime, @stat);
 local($[, $_);

 ;# check reference
 ref($l) eq 'HASH' || &abort("\$l must be a reference for HASH\n");
 ref($r) eq 'HASH' || &abort("\$r must be a reference for HASH\n");

 ;# check file types
 if ($l->{'type'} ne $r->{'type'}) {
  ;# file type mismatch!
  return 1;
 }

 ;# are they directories?
 if ($l->{'type'} eq 'directory') {
  ;# it seems to be a directory. we need check hierachies.
  return 1;
 }

 ;# are they symlinks? check link to
 if ($l->{'type'} eq 'symlink') {
  my $val;
  if (exists($r->{'reallinkto'})) {
   return $val if $val = $l->{'linkto'} cmp $r->{'reallinkto'};
  } else {
   return $val if $val = $l->{'linkto'} cmp $r->{'linkto'};
  }
  log::putl("INFO", "+ $r->{'path'} ... yes [SYMLINK]");
  return 0;
 }

 ;# remaining case must be `normal file'
 if ($l->{'type'} ne 'file') {
  log::putl("WARNING", "$l->{'type'}: unknown file type");
  return 0; # ignore this?
 }

 ;# check file size
 if ($r->{'size'} != $l->{'size'}) {
  ;# sizes differ
  return 1;
 }

 ;# checksum?
 if (defined($x = $r->{'md5checksum'}) && length($x) == 32) {
  # we may not have $l->{'md5checksum'}
  if (!(defined($y = $l->{'md5checksum'}) && length($y) == 32)) {
   $y = &dirinfo::md5checksum($l->{'path'});
   $l->{'md5checksum'} = $y if defined($y) && length($y) == 32;
  }
  if (defined($y) && length($y) == 32) {
   if (length($y) == 32 && $x eq $y) {
    log::putl("INFO", "+ $r->{'path'} ... yes [MD5CHKSUM]");
    return 0;
   } else {
    log::putl("DEBUG", "+ $r->{'path'} ... differs [MD5CHKSUM]");
    return 1;
   }
  } else {
   log::putl("DEBUG", "local system does not support MD5CHKSUM?");
  }
 }

 ;# If we have 'modified' parameter
 if (defined($r->{'modified'})) {
  # $l->{'modified'} is always defined.
  if ($r->{'modified'} == $l->{'modified'}) {
   log::putl("INFO", "+ $r->{'path'} ... yes [MODIFIED]");
   return 0;
  } else {
   log::putl("DEBUG", "+ $r->{'path'} ... differs [MODIFIED]");
   return 1;
  }
 }

 ;# use STAT or LIST rather than SIZE/MDTM
 if ($p->{'compare-stat'}) {
  ;# make date string
  my $date = $r->{'date'};
  my $ti = $l->{'modified'} + $p->{'offset'};
  my($sec, $min, $hour, $day, $month, $year) = gmtime($ti);
  my $mon = $nameofmonth[$month];

  $date =~ s/\s+/ /g;

  if ($date =~ /^\d\d-\d\d-\d\d \d\d:\d\d(AM|PM)$/i) { # DOS?
   $d = sprintf("%02d-%02d-%02d %02d:%02d%s",
   $month + 1, $day, $year, ($hour > 12 ? $hour - 12 : $hour),
   $min, ($hour > 12 ? 'PM' : 'AM'));
  } elsif ($date =~ /\s+\d\d:\d\d$/) {
   $d = sprintf("%s %d %02d:%02d", $mon, $day, $hour, $min);
  } elsif ($date =~ /\s+\d:\d\d$/) {
   $d = sprintf("%s %d %d:%02d", $mon, $day, $hour, $min);
  } else {
   $d = sprintf("%s %d %04d", $mon, $day, $year + 1900);
  }

  ;#
  if ($date eq $d) {
   log::putl("INFO", "+ $r->{'path'} ... yes [STAT/LIST]");
   return 0;
  }

  ;#
  log::putl("DEBUG", "(date: r = $date, l = $d)");
  log::putl("DEBUG", "(size: r = l = $r->{'size'})");
 } # or fail to compare in STAT/LIST

 ;# set time
 if (!defined($r->{'mtime'}) && !defined($p->{'no-mdtm'})) {
  if (defined($mtime = $x = &ftp::mtime($r->{'path'}))
   && $x =~ /^\d\d(\d\d)(\d\d)(\d\d)(\d\d)(\d\d)(\d\d)$/) {
   my($diff);

   $r->{'modified'} = &timegm($6, $5, $4, $3, $2 - 1, $1); # VALID!
   $r->{'mtime'} = $mtime;
#   $x = lsparse::lstime($r->{'date'});
   $x = $r->{'time'};
   $t = $x - $p->{'offset'};

   if ($p->{'compare-stat'} && abs($t - $r->{'modified'}) > 60 &&
       $r->{'date'} =~ /\d\d:\d\d$/) {
    my($sig, $z1, $z2, $h, $m);

    $diff = $x - $r->{'modified'};
    $sig = $diff < 0 ? '-' : '+';
    $diff = abs($diff);
    ;# z1 is real offset
    $h = int($diff / 3600);
    $m = int(($diff % 3600) / 60);
    $z1 = $sig.sprintf("%02d%02d", $h, $m);
    ;# but, we use z2
    $h = int(($diff + 1800) / 3600);
    $m = 0;
    $z2 = $sig.sprintf("%02d%02d", $h, $m);
    $z2 = 'this' if $z1 eq $z2;
    ;# find offset
    if ($h < 24) {
     $p->{'offset'} = 3600 * $h + 60 * $m;
     $p->{'offset'} = - $p->{'offset'} if $sig eq '-';
     log::putl("INFO", "[offset seems to be $z1, use $z2]");
    } else {
     log::putl("INFO", "[offset seems to be $z1, ignored]");
    }
   }
  } else {
   $p->{'no-mdtm'} = 1 if $ftp::buffer =~ /^5/;
  }
 }

 ;# If we have 'modified' parameter
 if (defined($r->{'modified'})) {
  # $l->{'modified'} is always defined.
  if ($r->{'modified'} == $l->{'modified'}) {
   log::putl("INFO", "+ $r->{'path'} ... yes [MDTM]");
   return 0;
  } elsif ($r->{'modified'} < 0 && $l->{'modified'} == 0) {
   log::putl("INFO", "+ $r->{'path'} ... yes (negative time)");
   return 0;
  } else {
   log::putl("DEBUG", "+ $r->{'path'} ... differs [MDTM]");
   return 1;
  }
 }

 ;# remaining case is !defined($r->{modified}) and time differs.
 return 1;
}

;#
;# When retrieve is called, compare was already called and it returned 1,
;# e.g. `remote/local files are different'. So, SIZE and TIME were
;# already caluculated by compare.
;# But, ls-lR may have wrong size/timestamp, so we should check them.
;#
sub retrieve {
 my($path, $r) = @_;
 my($s, $t, $x, $add, $mtime);

 ;# set time
 if (!defined($r->{'modified'})) {
  if (!defined($p->{'no-mdtm'})) {
   if (defined($mtime = $x = &ftp::mtime($r->{'path'}))
       && $x =~ /^\d\d(\d\d)(\d\d)(\d\d)(\d\d)(\d\d)(\d\d)$/) {
    $r->{'modified'} = &timegm($6, $5, $4, $3, $2 - 1, $1); # VALID!
    $r->{'mtime'} = $mtime;
   } else {
    $p->{'no-mdtm'} = 1 if $ftp::buffer =~ /^5/;
   }
  }
 }

 ;# get size
 if (!defined($p->{'no-size'})) {
  if (defined($s = &ftp::size($r->{'path'}))) {
   $r->{'size'} = $s;
  } else {
   $p->{'no-size'} = 1 if $ftp::buffer =~ /^5/;
  }
 }

 ;# The condition ($s == 0 or $t == 0) has a meaning.
 ;# So, undef $s and $t first.
 undef $s;
 undef $t;

 ;# get size and modified time
 $s = $r->{'size'} if defined($r->{'size'});
 $t = defined($r->{'modified'}) ? $r->{'modified'} :
   defined($r->{'time'}) ? $r->{'time'} - $p->{'offset'} : undef;

 ;# $t may be negative time
 if (defined($t) && $t < 0) {
  log::putl("INFO", "* negative time: use UTC");
  $t = 0;
 }

 ;# check once more...
 if (defined($r->{'md5checksum'}) && length($r->{'md5checksum'}) == 32) {
  ;# this file may be checked by md5checksum in compare().
 } else { # or size/timestamp check was applied in compare().
  if ($p->{'check-mtime'}) {
   if (defined($s) && &issame($path, $s, $t)) {
    log::putl("INFO", "+ $path ... no need to retrieve.");
    return 0;
   }
  } else { # no need to check mtime
   if (defined($s) && defined($t) && $s == -s $path) {
    log::putl("INFO", "* $path ... modifying mtime");
    if (!$p->{'test-mode'}) {
     if (!utime($t, $t, $path)) {
      log::putl("INFO", " utime: $!");
      return 0;
     } else {
      log::putl("INFO", " ok.");
     }
    }
    return 1;
   }
  }
 }

 ;#
 if ($p->{'log-priority'} > log::level("INFO")) {
  if (defined($t)) {
   my(@xx) = reverse((gmtime($t))[0..5]);
   $xx[0] += 1900; $xx[1]++;
   $add = sprintf("(%d, %04d%02d%02d%02d%02d%02d) ", $s, @xx);
  } else {
   $add = sprintf("(%d)", $s);
  }
 }

 ;# real work
 if ($p->{'test-mode'}) {
  log::putl("NOTICE", "+ $path $add... getting");
  return 1;
 }

 ;# go
 log::puts("NOTICE", "+ $path $add... getting");
 &ftp::retr($path)
  || do { log::putl("NOTICE", " error in xfer"); return undef };

 ;# change some attribute
 if (defined($t)) {
  if (!utime($t, $t, $path)) {
   log::puts("NOTICE", " (utime: $!)");
  }
 }

 ;# justify it
 if (!defined($s) || !defined($t) || &issame($path, $s, $t)) {
  log::putl("NOTICE", " done");
 } else {
  log::putl("NOTICE", " mismatch"); # something wrong.
 }

 ;# set file owner.group and mode
 &fileowner($path, $r);		# set owner and group ids
 &filemode($path, $r);		# set file mode

 ;# result?
 1;
}

;#
;#
sub store {
 my($path, $l) = @_;
 my($s, $t, $add, $mtime);

 ;# get size
 if (!defined($p->{'no-size'})) {
  if (!defined($s = &ftp::size($l->{'path'}))) {
   $p->{'no-size'} = 1 if $ftp::buffer =~ /^5/;
  }
 }

 ;# get size and modified time
 if ($s == -s $l->{'path'}) {
  log::putl("INFO", "+ $path ... no need to transfer.");
  return 0;
 }

 ;#
 if ($p->{'log-priority'} > log::level("INFO")) {
  $add = sprintf("(%d)", $s);
 }

 ;# real work
 if ($p->{'test-mode'}) {
  log::putl("NOTICE", "+ $path $add... putting");
  return 1;
 }

 ;# go
 log::puts("NOTICE", "+ $path $add... putting");
 &ftp::stor($path)
  || do { log::putl("NOTICE", " error in xfer"); return undef };

 ;# or success
 log::putl("NOTICE", " done");

 ;# result?
 1;
}

;#
sub issame {
 my($x, $s, $t) = @_;
 my(@stat);
 local($[);

 return (@stat = stat($x)) && $stat[7] == $s && $stat[9] == $t;
}

;#
sub mirror {
 my($p) = @_;
 my($tmplslR);

 ;# set umask
 umask($p->{'umask'});

 ;# make ftp session
 if (&ftp::login) {
  log::putl("DEBUG", "connecting to server ok.");
 } else {
  log::putl("WARNING", "can't login to server.");
  &ftp::quit;
  return undef;
 }

 ;# show transfer mode
 log::putl("DEBUG", "using "
  . ($p->{'ftp-passive'} ? 'PASV' : 'PORT')
  . " for data socket.");

 ;# set transfer type
 if (&ftp::type('I')) {
  log::putl("DEBUG", "set transfer type to binary.");
 } else {
  log::putl("WARNING", "can't set transfer type to binary");
  &ftp::quit;
  return undef;
 }

 ;# remote side directory
 my $rd = $p->{'remote-directory'};
 if (&ftp::cd($rd)) {
  log::putl("NOTICE", "remote directory is $rd.");
 } else {
  log::putl("WARNING", "can't change remote directory to \"$rd\".");
  &ftp::quit;
  return undef;
 }

 ;# local side directory
 my $ld = $p->{'local-directory'};
 if ($p->{'test-mode'} == 0) {
  &mkdirhier($ld) || return undef;
  chdir($ld) || do { log::putl("WARNING", "chdir($ld): $!"), return undef };
 } else {
  $p->{'directory-found'} = chdir($ld);
 }
 log::putl("NOTICE", "local directory is $ld.");
 log::putl("DEBUG", "ready to mirror the package.");

 ;# check ls-lR file
 if ($p->{'lslR-file'} ne '') {
  $tmplslR = "$p->{'temp-directory'}/ls$$";
  if ($p->{'lslR-file'} =~ /\.(gz|Z)$/) {
   $tmplslR .= $&;
  }
  my $subst = defined($p->{'lslR-subst'}) ? $p->{'lslR-subst'} : undef;
  $tempfiles{$tmplslR} = 1;
  log::puts("INFO", "loading $p->{'lslR-file'} ...");
  if (ftp::retr($p->{'lslR-file'}, $tmplslR)) {
   log::putl("INFO", " ok");
   &lsparse::scan_init($tmplslR, $subst);
   $p->{'lslR-scan'} = 1;
  } else {
   log::putl("INFO", " failed");
   unlink($tmplslR), delete($tempfiles{$tmplslR});
  }
 }

 ;# now mirror from current directory
 if (defined(&walk('.'))) {
  ;# check owner/mode of this directory
  &fileowner('.');
  &filemode('.');
 }

 ;# terminate FTP session
 &ftp::quit;

 ;# scan mode?
 if ($p->{'lslR-scan'}) {
  &lsparse::scan_done;
  unlink($tmplslR), delete($tempfiles{$tmplslR});
 }

 ;#
 log::putl("INFO", "FTP session was terminated normally.");

 ;# return true
 1;
}
