;#
;# Copyright (c) 1995-1998
;# Ikuo Nakagawa. All rights reserved.
;#
;# Redistribution and use in source and binary forms, with or without
;# modification, are permitted provided that the following conditions
;# are met:
;#
;# 1. Redistributions of source code must retain the above copyright
;# notice unmodified, this list of conditions, and the following
;# disclaimer.
;# 2. Redistributions in binary form must reproduce the above copyright
;# notice, this list of conditions and the following disclaimer in the
;# documentation and/or other materials provided with the distribution.
;#
;# THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' AND
;# ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
;# IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
;# PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS
;# BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY,
;# OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT
;# OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR
;# BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
;# WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE
;# OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE,
;# EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
;#
;# $Id: Fan.pm,v 1.42 1999/11/21 08:24:27 ikuo Exp $
;#
package Fan;
use strict;
use vars qw(@ISA $VERSION $LOG $sysconfdir $loader %pkeys %pnest %initval);
;# modules
use Carp;
use Fan::Param;
use Fan::Cool;
use Fan::Scan;
use Fan::Farm;
use Fan::Loader;
use AutoLoader 'AUTOLOAD';
;#
@ISA = qw(Fan::Param);
$VERSION = '0.03';
$LOG = 5;
;# Where configuration files are.
BEGIN {
$sysconfdir = '/usr/local/etc';
}
;#
%pkeys = (
'sysconfdir' => 'DIRECTORY',
'todo' => '',
'load_config' => '',
'username' => '',
'hostname' => '',
'create_directory' => 'BOOLEAN',
'alternate_package' => '',
'debug' => 'BOOLEAN',
'verbose' => 'BOOLEAN',
'log_label' => '',
'log_mask' => '',
'change_directory' => 'BOOLEAN',
'use_dirinfo' => 'BOOLEAN',
'load_remote_dirinfo' => 'BOOLEAN',
'load_local_dirinfo' => 'BOOLEAN',
'store_local_dirinfo' => 'BOOLEAN',
'ftp_debug' => 'BOOLEAN',
'ftp_stats' => 'BOOLEAN',
'ftp_timeout' => 'INTEGER',
'ftp_bindaddr' => 'IPv4_ADDR',
'ftp_passive' => 'BOOLEAN',
'ftp_server' => '',
'ftp_port' => '',
'ftp_gateway' => '',
'ftp_user' => '',
'ftp_pass' => '',
'ftp_group' => '',
'ftp_gpass' => '',
'ftp_login_retry' => 'INTEGER',
'ftp_login_delay' => 'INTEGER',
'ftp_idle' => 'INTEGER',
'ftp_max_idle' => 'INTEGER',
'ftp_offset' => 'INTEGER',
'ftp_force_mtime' => 'BOOLEAN',
'ftp_list_method' => 's/^(STAT|STAT-A|STAT-AT|LIST)$/\U$1/i || undef',
'via_http' => 'ref($_) eq "Fan::HTTP" || undef',
'via_ftp' => 'ref($_) eq "Fan::FTP" || undef',
'http_proxy' => '',
'lslR_file' => '',
'lslR_copy' => '',
'lslR_map' => '',
'compare_stat' => 'BOOLEAN',
'ignore_mtime' => 'BOOLEAN',
'override_file_uid' => '',
'override_file_gid' => '',
'override_file_mode' => 'OCTAL',
'override_directory_mode' => 'OCTAL',
'default_file_uid' => '',
'default_file_gid' => '',
'default_file_mode' => 'OCTAL',
'default_directory_mode' => 'OCTAL',
'backup_suffix' => '',
'test_mode' => 'BOOLEAN',
'remote_timezone' => 'TIMEZONE',
'lock_directory' => '',
'lock_file' => '',
'temp_directory' => '',
'master_db_directory' => '',
'local_db_directory' => '',
'remote_db_directory' => '',
'local_directory' => '',
'remote_directory' => '',
'transfer_file_regexp' => '',
'transfer_file' => 'CODE',
'transfer_directory_regexp' => '',
'transfer_directory' => 'CODE',
'override_file_regexp' => '',
'override_file' => 'CODE',
'override_directory_regexp' => '',
'override_directory' => 'CODE',
'follow_symlink_regexp' => '',
'follow_symlink' => 'CODE',
'symlink_map' => '',
'parse_realpath' => 'BOOLEAN',
'put_mode' => 'BOOLEAN',
'umask' => 'OCTAL',
'unlink' =>
'$_ = $_ eq "rename" ? 2 : &Fan::Param::want_boolean($_)',
'unlink_limit' => 'INTEGER',
'success_terminate' => 'BOOLEAN',
'use_master_db' => 'BOOLEAN',
);
;# nesting parameters.
%pnest = (
'archive' => 'PACKAGE::$_',
'package' => 'PACKAGE::$_',
'server' => 'SERVER::$_',
);
;# initial values.
%initval = (
'sysconfdir' => $sysconfdir,
'load_config' => "ftpmirror.cf",
'create_directory' => 1,
'override_file_uid' => 0,
'override_file_gid' => 0,
'override_file_mode' => '0644',
'override_directory_mode' => '0755',
'default_file_uid' => 0,
'default_file_gid' => 0,
'default_file_mode' => '0644',
'default_directory_mode' => '0755',
'unlink' => 'yes',
'backup_suffix' => '~',
);
;# Generate key oriented subroutines.
;#
for my $n (keys %pkeys) {
local $_ = $n;
eval "sub $n { my \$p = shift; \$p->setval('$n', shift) if \@_; \$p->getval('$n') }";
#eval "sub $n { my \$p = shift; \$p->{'$n'} = shift if \@_; \$p->{'$n'} }";
confess($@) if $@;
}
;# A special marker for AutoSplit.
1;
__END__
;# Initialize routine.
;#
sub full_setup ($$) {
my $this = shift; # may be class name.
my $arg = shift; # must a reference for an array.
# Cleanup loader first.
undef $loader;
# We must have loader.
$loader = Fan::Loader->new(
loader_keys => \%pkeys,
loader_nest => \%pnest,
);
ref($loader) && $loader->isa('Fan::Loader')
or croak("full_setup: can't create loader");
# Initial default parameters.
$loader->merge_hash(\%initval, 'INIT')
or croak("full_setup: can't initialize values");
# Parsing options.
$loader->parse_option($arg, 'OPTION')
or croak("full_setup: can't parse option");
# Initial array
my @array = qw(INIT OPTION);
# Set logging level first.
if (defined(my $mask = $loader->get_value('log_mask', @array))) {
plog_mask($mask);
}
# Configuration files to load.
if (defined(my $files = $loader->get_value('load_config', @array))) {
# Default directory for configuration files.
my $dir = $loader->get_value('sysconfdir', @array);
# load configuration files
for my $file (split(/\s+/, $files)) {
next if $file eq '';
$file = "$dir/$file"
if ! -f $file && $file !~ /^\// && $dir ne '';
warn("loading $file...\n") if $LOG > 5;
$loader->parse_file($file, 'DEFAULT')
or croak("full_setup: can't parse $file.\n");
}
}
# Success to full setup.
1;
}
;#
sub find_archive ($$) {
my $this = shift; # may be class name.
my $class = ref($this) || $this;
my $name = shift;
my $pack = 'PACKAGE::'.$name;
# Search this package...
unless ($loader->search($pack)) {
warn("find_archive: package $pack not defined.\n");
return undef;
}
# Parsers list.
my @list = ('INIT', 'DEFAULT', $pack, 'OPTION');
# Try to generate Archive object.
if (defined(my $srv = $loader->get_value('ftp_server', @list))) {
# If we have server parameter, try add it.
if ($loader->search('SERVER::'.$srv)) {
splice(@list, 2, 0, 'SERVER::'.$srv);
}
}
# Generate a new Archive object.
my $p = $class->new(param_name => 'RUN::'.$name);
unless (ref($p) && $p->isa('Fan::Param')) {
warn("find_archive: can't create Param object.\n");
return undef;
}
# Merge parameters.
for my $n (@list) {
$p->merge($loader->search($n));
}
# Set verbose or debug.
if ($p->debug || $p->verbose) {
my $n = $p->debug ? 7 : 6;
plog_mask("Fan=$n,Fan::Farm=$n");
$p->ftp_stats(1);
}
# Set logging level if given.
if (defined(my $mask = $p->log_mask)) {
plog_mask($mask);
}
# Check it
unless ($p->check) {
warn("find_archive: archive check error.\n");
return undef;
}
# Success.
$p;
}
;#
sub DESTROY {
my $p = shift;
# cleanup myself first.
$p->cleanup;
# date string..
my $t = time;
my $s = str4date($t).' '.str4time($t);
# result string.
# my $result = $p->success_terminate ? "normally" : "abnormally";
# package mirror done.
warn("$s $p->{param_name} terminated.\n") if $LOG >= 5;
# destroying log
warn("Fan DELETE [$p->{param_name}]\n") if $LOG >= 6;
# We also destroy my self in the super class.
Fan::Param::DESTROY($p);
}
;# Parse targets in the rest of the arguments.
sub new ($%) {
my $this = shift;
my $class = ref($this) || $this;
my %param = @_;
# set special keys for this param.
$param{param_keys} = \%pkeys;
# Generate a new Param object.
my $p = Fan::Param->new(%param);
ref($p) or confess("Can't create Param object");
# bless this
bless $p, $class;
# log messages...
warn("Fan CREATE [$p->{param_name}]\n") if $LOG >= 6;
# clear flags
$p->success_terminate(0);
# date string..
my $t = time;
my $s = str4date($t).' '.str4time($t);
# package mirror starting...
warn("$s $p->{param_name} starting.....\n") if $LOG > 4;
# return myself.
$p;
}
;# Check parameters
;# Most of parameters are checked by Fan::Param::setval.
sub check ($) {
my $p = shift; # Must be a generated module.
my $tmpkey;
my $tmpdir;
local $_;
# DEBUG purpose only...
ref($p) && $p->isa('Fan::Param')
or confess("$p must be a Fan::Param object");
# Check package name.
my $y = $p->{param_name};
if ($y !~ s/^RUN:://) {
# what's happen?
confess("$p: package name \"$y\" invalid");
}
# Default value for umask operation.
if (oct($p->umask)) {
umask(oct($p->umask));
}
# Default backup suffix is a tilda.
if ($p->backup_suffix eq '') {
$p->setval('backup_suffix', '~');
}
# Check username.
if ($p->username eq '') {
my $name = getpwuid($<);
defined($name) || die("getpwuid returns undef, at");
$p->setval('username', $name);
}
# Check hostname.
if ($p->hostname eq '') {
my $host;
chomp($host = `hostname`);
$host = 'nowhere' if $host eq '';
$p->setval('hostname', $host);
}
# Check FTP username.
if (!defined($p->ftp_user)) {
$p->setval('ftp_user', 'anonymous');
}
# Check FTP password string.
if (!defined($p->ftp_pass)) {
$p->setval('ftp_pass', $p->username.'@'.$p->hostname);
}
# Check existence of required directories.
for (qw|lock temp local remote master_db local_db remote_db|) {
my $key = $_.'_directory';
my $t = $p->subst_directory($p->getval($key));
if ($t ne '') {
$p->setval($key, $t);
} else {
$p->delete($key);
}
}
# Default value for temporary directory.
if (!defined($p->temp_directory)) {
$p->setval('temp_directory', $ENV{'TMPDIR'} || "/tmp");
}
# Default lock directory is local_directory...
if (!defined($p->lock_directory)) {
$p->setval('lock_directory', $p->temp_directory);
}
# Check required directories.
for (qw|local temp lock|) {
my $key = $_.'_directory';
my $t = $p->getval($key);
unless (defined($t)) {
warn("ERR($y): $_ directory \"$t\" not defined.\n");
return undef;
}
unless (-d $t) {
unless ($p->create_directory && mkdirhier($t, 0755)) {
warn("ERR($y): mkdirhier(\"$t\") failed.\n");
return undef;
}
}
}
# Check archive database directories...
# remote_db_directory
# local_db_directory
# Check index directory.
# master_db_directory
# default value of *_dirinfo
if ($p->use_dirinfo) {
$p->setval('load_remote_dirinfo', 1)
if !defined($p->load_remote_dirinfo);
$p->setval('load_local_dirinfo', 1)
if !defined($p->load_local_dirinfo);
$p->setval('store_local_dirinfo', 1)
if !defined($p->store_local_dirinfo);
}
# load dirinfo?
if ($p->load_remote_dirinfo) {
my $z = $p->transfer_file_regexp;
$p->setval('transfer_file_regexp', "\n".'!/\/\.dirinfo/'.$z);
}
# load dirinfo?
if ($p->store_local_dirinfo) {
my $z = $p->override_file_regexp;
$p->setval('override_file_regexp', "\n".'!/\/\.dirinfo/'.$z);
}
# We must ignore lock files.
if ($p->local_directory eq $p->lock_directory) {
my $z = $p->override_file_regexp;
$p->setval('override_file_regexp', "\n".'!/\.\/\.LOCK$/'.$z);
}
# We must not unlink renamed file if unlink == 2
if ($p->unlink == 2) {
my $z = $p->override_file_regexp;
$p->setval('override_file_regexp',
"\n".'!/'.$p->backup_suffix.'$/'.$z);
$z = $p->override_directory_regexp;
$p->setval('override_directory_regexp',
"\n".'!/'.$p->backup_suffix.'\/$/'.$z);
}
# `change_directory = 1' is required
# if `follow_symlink_regexp' is defined.
$p->setval('change_directory', 1) if defined($p->follow_symlink);
# Obsolete message.
if (defined($p->{'lslR_map'})) {
warn("WARN($y): lslR_map was obsoleted, ignored\n");
delete($p->{'lslR_map'}); # obsolete
}
# If we create a copy of remote lslR file, we must not override it.
if ($p->lslR_copy =~ /^[^\/]/) { # relative path...
my $copy = lookup($p->lslR_copy);
my $z = $p->override_file_regexp;
$p->setval('override_file_regexp',
"\n".'!/\.\/'.quotemeta($copy).'$/'.$z);
}
# Generate match routine
for $tmpkey (qw(override_directory override_file
transfer_directory transfer_file follow_symlink)) {
$_ = $p->getval($tmpkey.'_regexp') || '';
s/^\n//;
my $c = &gen_match(split(/\n/));
defined($c)
or warn("ERR($y): $_ could not be defined\n"),
return undef;
$p->setval($tmpkey, $c);
}
# Generate substitution routine
if (defined($_ = $p->symlink_map) && $_ ne '') {
s/^\n//; # ignore first newline.
my $c = &gen_subst(split(/\n/));
ref($c) eq 'CODE'
or warn("ERR($y): symlink-map error.\n"),
return undef;
$p->setval('symlink_subst', $c);
}
# Calculate timezone offset.
if (defined($_ = $p->remote_timezone)) {
if (/^(\+|-)(\d\d?)(\d\d)$/) {
my $off = $2 * 3600 + $3 * 60;
$p->setval('offset', $1 eq '+' ? $off : (0 - $off));
}
}
;# success
$p;
}
;# substitute directory names
sub subst_directory ($$) {
my $self = shift; # this must be a Package object.
my $dir = shift;
# try to expand.
defined($dir = &Fan::Param::want_path($dir)) || return undef;
# try to substitute.
my $name = $self->{param_name};
if ($name =~ s/^(RUN|PACKAGE):://) {
$dir =~ s/\%s/$name/g;
}
$dir;
}
;# make pattern match subroutine
sub gen_match ($) {
my $func = undef;
my $default = 1;
my $s = "\$func = sub {\n\tlocal(\$_) = \@_;\n";
for my $re (@_) {
local $_ = $re;
my $type = s/^!// ? 0 : 1;
my $use_regexp = 0;
if (m%^/(.*)/$%) { # use regexp
$_ = $1; $use_regexp = 1;
} elsif (m%^'(.*)'$%) { # just match
$_ = $1;
}
if ($_ eq '') {
$default = $type; last;
}
if ($use_regexp) {
$s .= "\treturn $type if /$_/o;\n";
} else {
$s .= "\treturn $type if \$_ eq '$_';\n";
}
}
$s .= "\t$default;\n}\n";
# debug information
print "match: $s" if $LOG > 7;
# evaluate subroutine definition
eval $s;
confess $@ if $@;
# success - returns CODE.
$func;
}
;# make pattern substitute subroutine
sub gen_subst ($) {
my $func = undef;
my $s = "\$func = sub {\n\tlocal(\$_) = \@_;\n";
for my $re (@_) {
if ($re =~ m,^s/,) {
$s .= "\t$re;\n";
} elsif ($re =~ m,^/,) {
$s .= "\ts$re;\n";
} else {
$s .= "\ts/$re/;\n";
}
}
$s .= "\t\$_;\n}\n";
# debug information
print "subst: $s" if $LOG > 7;
# evaluate subroutine definition
eval $s;
confess $@ if $@;
# success
$func;
}
;#
sub do_lock {
my $p = shift;
my $package = $p->{param_name};
my $d = $p->lock_directory;
# Check lock directory again.
unless (-d $d && -w $d) {
warn("$d: directory not found.\n");
return undef;
}
# Try to lock this package...
$package =~ s/^RUN:://
or confess("ERR $package is invalid package name");
my $lock = $d.'/LOCK.'.encode($package);
# Lock mechanizm is supported by Cool.pm.
plock($lock, 30) # wait max 30 seconds.
or warn("plock($lock): $!\n"), return undef;
# Register $lock as a temporary file.
$p->{tempfiles}->{$lock}++;
# Success
1;
}
;#
sub cleanup ($) {
my $p = shift;
# cleanup network sessions
$p->delete('via_http');
$p->delete('via_ftp');
# cleanup temporary files.
for my $file (keys %{$p->{tempfiles}}) {
if (-e $file) {
warn("unlink $file...\n") if $LOG > 5;
unlink($file); # ignore result
}
}
# always success.
1;
}
;# Initialize network
;# FTP or HTTP(proxy)
;#
sub net_init {
my $p = shift;
my $package = $p->{param_name};
my $msg = '';
# fast return for initialized package
return 1 if $p->{net_initialized};
# Check package name first.
$package =~ s/^RUN:://
or confess("ERR $package is invalid package name");
# do lock in put mode
unless ($p->put_mode || $p->do_lock) {
warn("$package: can't lock the package.\n");
return undef;
}
# Check ftp-server.
if ($p->ftp_server eq '') {
warn("ERR($package) no FTP server defined.\n");
return undef;
}
# And remote_directory.
if ($p->remote_directory eq '') {
warn("ERR($package) no remote_directory defined.\n");
return undef;
}
# abbrevs for remote directory.
# You can use HTTP to transfer files.
# In this case, at least one of lslR_file, archive_index,
# or load_remote_dirinfo must be given.
if ($p->http_proxy) {
use Fan::HTTP;
my $http = Fan::HTTP->new(
http_proto => 'ftp',
http_server => $p->ftp_server,
http_proxy => $p->http_proxy);
ref($http)
or warn("Can't create HTTP object"), return undef;
plog(5, "using HTTP proxy for file transfer.\n");
$msg = "server = ".$p->ftp_server;
$msg .= " (http via ".$p->http_proxy.")";
plog(5, $msg."\n");
$p->setval('via_http', $http);
} else {
use Fan::FTP;
my %param = (
ftp_server => $p->ftp_server,
ftp_user => $p->ftp_user,
ftp_pass => $p->ftp_pass,
ftp_directory => $p->remote_directory,
);
$param{ftp_gateway} = $p->ftp_gateway
if $p->ftp_gateway ne '';
$param{ftp_bindaddr} = $p->ftp_bindaddr
if $p->ftp_bindaddr ne '';
$param{ftp_login_retry} = $p->ftp_login_retry
if $p->ftp_login_retry > 0;
$param{ftp_login_delay} = $p->ftp_login_delay
if $p->ftp_login_delay > 0;
$param{ftp_port} = $p->ftp_port
if $p->ftp_port > 0;
$param{ftp_group} = $p->ftp_group
if $p->ftp_group ne '';
$param{ftp_gpass} = $p->ftp_gpass
if $p->ftp_gpass ne '';
$param{ftp_passive} = 1
if $p->ftp_passive;
$param{ftp_idle} = $p->ftp_idle
if $p->ftp_idle > 0;
$param{ftp_idle} = -1
if $p->ftp_max_idle;
$param{ftp_timeout} = $p->ftp_timeout
if $p->ftp_timeout > 0;
$param{tcp_debug} = 1
if $p->ftp_debug;
$param{ftp_stats} = 1
if $p->ftp_stats;
my $ftp = Fan::FTP->new(%param);
unless (ref($ftp)) {
warn("Can't create FTP object");
return undef;
}
plog(5, "using FTP for file transfer.\n");
# Show server name.
$msg = "server = ".$p->ftp_server;
$msg .= " (ftp via ".$p->ftp_gateway.")" if $p->ftp_gateway;
plog(5, $msg."\n");
# Show user account.
$msg = "username = ".$p->ftp_user;
$msg .= '/'.$p->ftp_pass
if $p->ftp_user eq 'ftp' || $p->ftp_user eq 'anonymous';
plog(5, $msg."\n");
# WE USE DELAYED LOGIN, THAT IS, WE WILL LOGIN WHEN FIRST COMMAND
# WILL SEND TO THE SERVER.
# plog(5, "try login...\n");
#
# unless ($ftp->login) {
# warn("net_init: can't login to the server");
# return undef;
# }
$p->setval('via_ftp', $ftp);
}
# And, some additional information.
plog(5, "transfer type = ".($p->put_mode ? 'put' : 'get')."\n");
# network flag
$p->{net_initialized}++;
# success to init network methods...
1;
}
;#
;#
sub last_seq ($;$) {
my $p = shift;
# writing lastest step file.
local *FILE;
my $last = @_ ? shift : 0;
my $seq = $p->local_db_directory.'/work.seq';
if ($last > 0) { # write mode
unless (open(FILE, '>'.$seq)) {
warn("last_seq: open(>$seq): $!\n");
return undef;
}
print FILE $last."\n";
close(FILE);
warn("last_seq: wrote $last to $seq\n") if $LOG > 5;
} else {
unless (open(FILE, $seq)) {
warn("last_seq: open($seq): $!\n") if $LOG > 5;
return undef;
}
$last = <FILE>;
close(FILE);
chomp($last);
unless ($last > 0) {
warn("last_seq: can't read from $seq\n");
return undef;
}
$last += 0;
warn("last_seq: read last = $last from $seq\n") if $LOG > 5;
}
$last;
}
;#
;#
sub step_synch {
my $p = shift; # Fan object...
unless ($p->net_init) {
warn("step_synch: can't initialize network");
return undef;
}
my $ldb = $p->local_db_directory;
if ($ldb eq '') {
carp("step_synch: no local_db_directory defined");
return undef;
}
if (! -d $ldb) {
carp("step_synch: local_db_directory is not a directory");
return undef;
}
my $db = Fan::Farm->new($ldb);
unless (ref($db)) {
carp("step_synch: can't create Fan::Farm object");
return undef;
}
my $rdb = $p->remote_db_directory;
if ($rdb eq '') {
if (! -f "$ldb/index.local") {
carp("step_synch: neither remote_db_directory nor"
. " local index found");
return undef;
}
warn("step_synch: no remote_db_directory"
. ", use local mode.\n")
if $LOG > 5;
} else {
my $notrans = 0;
my $a = Fan::Attrib->new(
y_type => 'F',
y_path => "$rdb/index.local",
y_name => "index.local",
);
unless (ref($a)) {
carp("step_synch: can't create Fan::Attrib object");
return undef;
}
if (-f "$ldb/index.local" && ref($a)) {
warn("step_synch: $ldb/index.local found\n") if $LOG > 6;
$b = Fan::Attrib->new(attr_path => "$ldb/index.local");
unless (ref($b)) {
carp("step_synch: can't create"
. " Fan::Attrib object");
return undef;
}
$p->fill_size($a);
$p->fill_mtime($a);
if ($a->size == $b->size && $a->mtime == $b->mtime) {
$notrans++;
}
} else {
warn("step_synch: $ldb/index.local not found\n") if $LOG > 6;
}
if ($notrans) {
warn("step_synch: no need to transfer index.local\n")
if $LOG > 5;
} elsif ($p->get("$rdb/index.local", "$ldb/index.local")) {
warn("step_synch: got index.local: o.k.\n")
if $LOG > 5;
} else {
carp("step_synch: can't retrieve index.local");
return undef;
}
my $m = $a->mtime;
utime($m, $m, "$ldb/index.local") if $m > 0;
unless ($db->synch($p, $rdb, "$ldb/index.local")) {
carp("step_synch: can't synchronise to remote");
return undef;
}
warn("step_synch: synch o.k.\n") if $LOG > 5;
}
# get local revisions, again.
unless ($db->getrev) {
carp("step_synch: can't get revision");
return undef;
}
# check latest index file
unless ($db->{pim_index_max} > 0) {
carp("step_synch: no index file found");
return undef;
}
# get index file, and step files
$p->{newest_index} = $db->{pim_index_max};
$p->{newest_index_file} = "$ldb/index.$p->{newest_index}";
# log it
warn("step_synch: newest index is $p->{newest_index_file}.\n")
if $LOG > 5;
# can we get last seq?
my $last = $p->last_seq;
unless ($last > 0) {
warn("step_synch: last# is not found $last.\n") if $LOG > 5;
return 1;
}
# search step files
$p->{newer_step_files} = [];
if ($db->{pim_step_max} > $last) {
if ($last < $db->{pim_step_min}) {
warn("step_synch: step index is larger than mine.\n")
if $LOG > 4;
$last = $db->{pim_step_min};
}
for (my $i = $last; $i <= $db->{pim_step_max}; $i++) {
push(@{$p->{newer_step_files}}, "$ldb/step.$i");
warn("step_synch: add step $ldb/step.$i.\n")
if $LOG > 5;
$p->{newest_step} = $i;
}
}
# success
1;
}
;#
;#
sub run_step_mirror {
my $p = shift;
unless ($p->net_init) {
warn("step_synch: can't initialize network");
return undef;
}
#
unless ($p->step_synch) {
carp("step_mirror: can't sync..., try full mirror");
return undef;
}
# check if we have newer step files?
unless (exists($p->{newer_step_files})) {
warn("step_mirror: no step files to synch.\n") if $LOG > 4;
return 1;
}
# check if we have newer step files?
unless (@{$p->{newer_step_files}}) {
warn("step_mirror: empty step file array.\n") if $LOG > 4;
return 1;
}
# or we have something to mirror
my @newer_scan = ();
# generate scans...
for my $i (@{$p->{newer_step_files}}) {
my $scan = Fan::Scan->new(
scan_type => 'INDEX',
scan_index => $i
);
unless (ref($scan)) {
carp("step_mirror: can't create Scan for $i");
return undef;
}
unless ($scan->add_filter(\&server_filter, $p)) {
carp("step_mirror: can't add filter for $i");
return undef;
}
push(@newer_scan, $scan);
}
#
warn("step_mirror: starting\n") if $LOG > 5;
my $base = shift(@newer_scan);
my @x;
while (@x = $base->getcmp(@newer_scan)) {
my $x;
# search lastest one
for my $y (@x) {
$x = $y if ref($y);
}
ref($x) or confess("UNEXPECTED CASE");
my $f = $x->flag;
my $t = $x->type;
# check end-of-data
last if $t eq '.';
# get pathname
my $path = $x->path;
my $show = &Fan::Attrib::attr_encode($path);
# check flag...
if ($f eq '-') { # DELETE
if ($t eq 'D') {
; # simply ignored
} elsif ($p->del($x)) {
plog(5, "-$t $show: success\n");
} else {
plog(5, "-$t $show: failure\n");
}
} elsif ($f eq '+' || $f eq '') { # ADD
my $realpath = $p->local_directory.'/'.$x->path;
my $a = undef;
my $m = 0;
my $op = $p->test_mode ? 3 : 2;
$a = Fan::Attrib->new(attr_path => $realpath)
if $t ne 'U' && -e $realpath;
if ($t eq 'U') {
; # simply ignored
} elsif ($a && defined($m = $p->besame($a, $x, $op))) {
if ($m) {
plog(5, "+$t $show: modified\n");
} else {
plog(5, "#$t $show: o.k.\n");
}
} elsif ($p->add($x)) {
plog(5, "+$t $show: success\n");
} else {
plog(5, "+$t $show: failure\n");
}
} else {
; # unknown flags...
}
}
# writing lastest step file.
unless ($p->last_seq($p->{newest_step} + 1)) {
warn("step_mirror: can't write last seq.\n") if $LOG > 5;
return undef;
}
warn("step_mirror: done.\n") if $LOG > 5;
#
1;
}
;#
;#
sub run_full_mirror {
my $p = shift; # Fan object...
warn("full_mirror: started\n") if $LOG > 5;
unless ($p->net_init) {
warn("step_synch: can't initialize network");
return undef;
}
my $server = $p->remote_scanner;
unless (ref($server)) {
# carp("Can't create Scan object for FTP");
return undef;
}
# local side scanner
my $client = $p->local_scanner;
unless (ref($client)) {
# carp("Can't create Scan object");
return undef;
}
# temporary variables...
my $farm = undef;
# check transfer mode
if ($p->put_mode) {
($server, $client) = ($client, $server);
} else {
# check index directory
my $d = $p->master_db_directory;
if (-d $p->local_db_directory) {
; # this is slave server.
} elsif ($d eq '') {
; # no master_db_directory defined
} elsif (! -d $d) { # warn, but ignored...
warn("full_mirror: $d is not a directory.\n")
if $LOG > 4;
} else {
$farm = Fan::Farm->new($d);
unless (ref($farm) && $farm->d_begin) {
warn("full_mirror: can't initialize Farm\n")
if $LOG > 5;
undef $farm;
}
}
}
my $x;
my $y;
while (($x, $y) = $client->getcmp($server)) {
# result should be in $z.
my $z;
my $flag;
my $modify = undef;
# One of $x or $y must be defined.
if (!defined($x) && !defined($y)) {
die("Both of \$x and \$y are undef");
} elsif (!defined($x)) { # only in server.
$z = $y;
$flag++;
} elsif (!defined($y)) { # only in client.
$z = $x;
$flag--;
} else { # in both of client and server
$z = $y;
$flag = 0;
}
# type abbrev...
my $t = $z->type;
# Is this END-OF-DATA?
if ($t eq '.') {
$flag == 0 or die("UNEXPECTED END-OF-DATA");
$p->setval('success_terminate', 1);
last;
}
# Check if we must get mtime of the file.
# This must be before besame in the next block.
if ($t eq 'F' && $p->ftp_force_mtime) {
$p->fill_mtime($x) if ref($x) && !defined($x->mtime);
$p->fill_mtime($y) if ref($y) && !defined($y->mtime);
}
# $flag == 0 means, both of server and client have
# a file named $z->path.
# Check if we must get/put file or not.
# Besame returns undef if we must transfer the target.
if ($flag == 0) {
# Is checksum required?
if ($t eq 'F' && !$p->put_mode) {
# If target has checksum, we should fill it.
if (length($y->checksum) == 32) {
$x->fill_checksum if -f $x->realpath;
}
}
# Check if we can modify or we must transfer.
my $op = $p->test_mode ? 3 : 2;
$op |= 8 unless $p->ignore_mtime;
$modify = $p->besame($x, $y, $op);
$flag++ if !defined($modify);
}
# DEBUG only - check override...
# This block can be skipped, since override check
# was already done in add_filter for Scan object.
# Can we override this?
if ($t eq 'D') {
my $file = $z->path;
unless (&{$p->override_directory}($file.'/')) {
die("overrite_directory violation: $file/\n");
}
} elsif ($t eq 'F' || $t eq 'L') {
my $file = $z->path;
unless(&{$p->override_file}($file)) {
die("overrite_file violation: $file/\n");
}
}
# show logging
my $show = &Fan::Attrib::attr_encode($z->path);
# Now, we can override.
# Do real action.
if ($flag < 0) { # DELETE
$z->flag('-');
if ($t eq 'D') {
; # simply ignored
} elsif ($p->del($z)) {
plog(5, "-$t $show: success\n");
} else {
plog(5, "-$t $show: failure\n");
}
} elsif ($flag > 0) { # ADD
$z->flag('+');
if ($t eq 'U') {
; # simply ignored
} elsif ($p->add($z)) {
plog(5, "+$t $show: success\n");
} else {
plog(5, "+$t $show: failure\n");
$flag = -1;
}
} else {
$z->flag('');
if ($t eq 'U') {
; # do nothing...
} elsif ($modify) {
$z->flag('+');
plog(5, "+$t $show: modified\n");
} else {
plog(6, "#$t $show: ok\n");
}
}
# Package index mangement tools
if (ref($farm)) {
# fill attributes...
if ($flag >= 0) {
$z->fill($p->local_directory.'/'.$z->path)
or confess("Can't fill Fan::Attrib("
. $z->path . ")");
if ($t eq 'F' && length($z->checksum) != 32) {
$z->fill_checksum;
}
}
$farm->d_add($z);
}
# Check critical error...
die("Fatal error detected in ftp connection, at")
if ref($p->via_ftp) &&
$p->via_ftp->error == &Fan::TCP::FATAL;
}
# terminate network connection before heavy processing...
undef $x;
undef $y;
$p->quit;
# try terminate updater
if (ref($farm)) {
warn("full_mirror: terminate updater...\n") if $LOG > 5;
$farm->d_end;
warn("full_mirror: normalize my farm...\n") if $LOG > 5;
$farm->normalize;
warn("full_mirror: generate local index...\n") if $LOG > 5;
$farm->genindex;
}
# writing lastest step file.
if ($p->{newest_index} > 0) {
my $seq = $p->{newest_index};
if ($seq > 0 && $p->last_seq($seq)) {
warn("full_mirror: wrote last seq = $seq.\n")
if $LOG > 5;
} else {
warn("full_mirror: can't write last seq.\n")
if $LOG > 5;
}
}
# cleanup.
$p->cleanup;
# debug log...
warn("full_mirror: done.\n") if $LOG > 5;
#
1;
}
;#
;#
sub quit ($) {
my $p = shift;
my $x;
if (ref($x = $p->via_http)) {
;
} elsif (ref($x = $p->via_ftp)) {
$x->quit;
} else {
;
}
1;
}
;#
;#
sub list ($$) {
my $p = shift;
my $dir = shift;
my $x;
if (ref($x = $p->via_http)) {
confess("HTTP does not support LIST");
} elsif (ref($x = $p->via_ftp)) {
unless ($x->ascii) {
warn("FTP->ascii failed");
return undef;
}
if ($p->ftp_list_method eq 'LIST') {
return $x->list($dir);
} elsif ($p->ftp_list_method eq 'STAT-A') {
$x->chdir($dir) || return undef;
return $x->stat("-A .");
;# if ( not $x->chdir($p->remote_directory) ) { return 1; }
} elsif ($p->ftp_list_method eq 'STAT-AT') {
$x->chdir($dir) || return undef;
return $x->stat("-AT .");
;# if ( not $x->chdir($p->remote_directory) ) { return 1; }
} else {
my $temp = $x->stat($dir);
if ($temp eq "" ) {
$p->ftp_list_method eq 'LIST';
return $x->list($dir);
} else {
return $temp;
}
}
} else {
confess("No listing method");
}
undef;
}
;#
;#
sub get ($$;$) {
my $p = shift;
my $remote_file = shift;
my $local_file = @_ ? shift : $remote_file;
my $x;
if (ref($x = $p->via_http)) {
$remote_file = $p->remote_directory.'/'.$remote_file
if $remote_file !~ /^\//;
unless ($x->get($remote_file, $local_file)) {
warn("HTTP->get($remote_file) error ".$x->error);
return undef;
}
} elsif (ref($x = $p->via_ftp)) {
unless ($x->image) {
warn("FTP->image failed");
return undef;
}
unless ($x->get($remote_file, $local_file)) {
warn("FTP->get($remote_file) error ".$x->error);
return undef;
}
} else {
confess("No transfer method"), return undef;
}
# success to get files.
1;
}
;#
;#
sub put ($$;$) {
my $p = shift;
my $local_file = shift;
my $remote_file = @_ ? shift : $local_file;
my $x;
if (ref($x = $p->via_http)) {
confess("HTTP does not support PUT");
} elsif (ref($x = $p->via_ftp)) {
$x->image
or warn("FTP->image failed"), return undef;
$x->put($local_file, $remote_file)
or warn("FTP->put failed"), return undef;
} else {
confess("No transfer method"), return undef;
}
# success to get files.
1;
}
;#
sub fill_mtime ($$) {
my $p = shift; # myself
my $y = shift; # Attrib
# debug log...
warn("fill_mtime: try ".$y->path."\n") if $LOG > 6;
# check if $y->mtime is defined.
if (defined($y->mtime)) {
warn("fill_mtime: already has mtime.\n") if $LOG > 6;
return 1;
}
# we need ftp to get mtime.
my $ftp = $p->via_ftp;
unless (ref($ftp)) {
warn("fill_mtime: no ftp session found.\n") if $LOG > 6;
return undef;
}
# try to get mtime.
my $m = $ftp->mtime($y->path);
unless (defined($m) && $y->mtime($m)) {
warn("fill_mtime: fail to get mtime\n") if $LOG > 6;
return undef;
}
# mtime found, debug log...
warn("fill_mtime: $m (".$y->path.").\n") if $LOG > 6;
# can we set offset value?
if ($y->date =~ /\d\d+:\d\d/) {
my $off = $p->ftp_offset;
my $off2 = $y->time0 - $y->mtime;
if (!defined($off) || abs($off - $off2) > 600) {
$p->adjust_offset($y->mtime, $y->time0);
}
}
# result must be o.k.
1;
}
;#
sub fill_size ($$) {
my $p = shift; # myself
my $y = shift; # Attrib
# debug log...
warn("fill_size: try ".$y->path."\n") if $LOG > 6;
# check if $y->size is defined.
if (defined($y->size)) {
warn("fill_size: already has size.\n") if $LOG > 6;
return 1;
}
# we need ftp to get size.
my $ftp = $p->via_ftp;
unless (ref($ftp)) {
warn("fill_size: no ftp session found.\n") if $LOG > 6;
return undef;
}
# size command requires image mode
unless ($ftp->image) {
warn("fill_size: can't goto image mode\n") if $LOG > 6;
return undef;
}
# try to get size.
my $s = $ftp->size($y->path);
unless (defined($s) && $y->size($s)) {
warn("fill_size: fail to get size\n") if $LOG > 6;
return undef;
}
# size found, debug log...
warn("fill_size: $s (".$y->path.").\n") if $LOG > 6;
# result must be o.k.
1;
}
;#
sub add {
my $p = shift;
$p->put_mode ? $p->remote_add(@_) : $p->local_add(@_);
}
;#
sub del {
my $p = shift;
$p->put_mode ? $p->remote_del(@_) : $p->local_del(@_);
}
;#
sub local_add {
my $p = shift; # Fan
my $y = shift; # Attrib we should add
my $t = $y->type;
my $from = $y->path; # server side file
my $to = $p->local_directory.'/'.$from;
1 while $to =~ s|/\./|/|;
if ($t eq 'D') {
return 1 if $p->test_mode;
unlink($to); # force to remove
unless (mkdir($to, 0755)) {
warn("mkdir($to): $!");
return undef;
}
warn("mkdir($from, 0755): o.k.\n") if $LOG > 6;
} elsif ($t eq 'U') {
; # simply ignored
} elsif ($t eq 'F') {
return 1 if $p->test_mode;
# fill mtime if we don't have it
$p->fill_mtime($y);
# try to get file.
unless ($p->get($from, $to)){
warn("get($from, $to) failed: ");
return undef;
}
warn("net::get($from): o.k.\n") if $LOG > 6;
} elsif ($t eq 'L') {
return 1 if $p->test_mode;
unlink($to); # force to remove
unless (symlink($y->linkto, $to)) {
warn("symlink: $!");
return undef;
}
warn("symlink($from): o.k.\n") if $LOG > 6;
} else {
; # what?
}
# Check modified file.
my $a = Fan::Attrib->new(attr_path => $to);
unless (ref($a) && $a->isa('Fan::Attrib')) {
warn("Fan::Attrib::new $!");
return undef;
}
# copy path variable
$a->path($from);
# check attribute again
unless (defined($p->besame($a, $y, 2))) {
warn("Can't modify $from");
return undef;
}
# success
1;
}
;#
sub local_del {
my $p = shift; # Fan
my $y = shift; # Attrib
my $t = $y->type;
my $org = $y->path;
my $old = $p->local_directory.'/'.$org;
1 while $old =~ s|/\./|/|;
if ($p->unlink == 0) {
warn("unlink($org) skipped by unlink-mode\n") if $LOG > 5;
return 0;
} elsif ($p->unlink == 2) {
my $xx = $old.$p->backup_suffix;
return 1 if $p->test_mode;
unless (rename($old, $xx)) {
warn("rename($old, $xx): $!");
return undef;
}
warn("rename $org: o.k.\n") if $LOG > 6;
return 1;
}
if ($t eq 'D') {
; # rmdir when 'U' was found
} elsif ($t eq 'U') {
return 1 if $p->test_mode;
unless (rmdir($old)) {
warn("rmdir($old): $!");
return undef;
}
warn("rmdir($org): o.k.\n") if $LOG > 6;
} else {
return 1 if $p->test_mode;
unless (unlink($old)) {
warn("unlink($old): $!");
return undef;
}
warn("unlink($org): o.k.\n") if $LOG > 6;
}
1;
}
;#
sub remote_add {
my $p = shift; # Fan
my $y = shift; # Attrib
my $t = $y->type;
my $to = $y->path;
my $from = $p->local_directory.'/'.$to;
1 while $from =~ s|/\./|/|;
my $ftp = $p->via_ftp;
ref($ftp) or confess("FTP is required for remote operation");
if ($t eq 'L') {
plog(7, "! We can't put symlink for $to, try real data.\n");
$t = 'F';
}
if ($t eq 'D') {
return 1 if $p->test_mode;
$ftp->unlink($to); # ignore result.
unless ($ftp->mkdir($to)) {
warn("net::mkdir($to): ".$ftp->error);
return undef;
}
warn("FTP::mkdir($to): o.k.\n") if $LOG > 6;
} elsif ($t eq 'U') {
; # simply ignored
} elsif ($t eq 'F') {
return 1 if $p->test_mode;
unless ($ftp->image) {
warn("FTP::image failed ".$ftp->error);
return undef;
}
unless ($ftp->put($from, $to)) {
warn("FTP::put($to): ".$ftp->error);
return undef;
}
warn("FTP::put($to): o.k.\n") if $LOG > 6;
} else {
; # what?
}
if (($t eq 'D' || $t eq 'F') && (my $val = $y->perm) > 0) {
# warn("try chmod $to\n");
unless ($ftp->chmod($val, $to)) {
warn("FTP::chmod($to): [".$ftp->error."]\n")
if $LOG >= 6;
# but ignore this error
}
}
1;
}
;#
sub remote_del {
my $p = shift; # Fan
my $y = shift; # Attrib
my $t = $y->type;
my $old = $y->path;
my $ftp = $p->via_ftp;
ref($ftp) or confess("FTP is required for remote operation");
if ($p->unlink == 0) {
warn("unlink($old) skipped by unlink-mode\n") if $LOG > 5;
return 0;
} elsif ($p->unlink == 2) {
my $xx = $old.$p->backup_suffix;
return 1 if $p->test_mode;
unless ($ftp->rename($old, $xx)) {
warn("FTP::rename($old, $xx): $!");
return undef;
}
warn("FTP::rename $old: o.k.\n") if $LOG > 6;
return 1;
}
if ($t eq 'D') {
; # rmdir when 'U' was found
} elsif ($t eq 'U') {
plog(7, "FTP::rmdir($old)\n");
return 1 if $p->test_mode;
unless ($ftp->rmdir($old)) {
warn("FTP::rmdir($old): ".$ftp->error);
return undef;
}
warn("FTP::rmdir($old): o.k.\n") if $LOG > 6;
} else {
plog(7, "FTP::unlink($old)\n");
return 1 if $p->test_mode;
unless ($ftp->unlink($old)) {
warn("FTP::unlink($old): ".$ftp->error);
return undef;
}
warn("FTP::unlink($old): o.k.\n") if $LOG > 6;
}
1;
}
;#
;# $p->besame($a, $b, $op)
;# where $a and $b are Attrib objects,
;#
;# $op is the operation code and flags.
;#
;# case of ($op & 7) == 0:
;# Function `besame' simply checks whether $a is same as $b.
;# If $a is equevalent to $b then 0(zero) will be returned,
;# otherwise undef will be returned.
;# case of ($op & 7) == 1:
;# Same as the case of $op == 0, but modification times are
;# good if the condition (mtime_of_$a >= mtime_of_$b) holds.
;# case of ($op & 7) == 2:
;# Function `besame' checks and try to modify $a to be same
;# as $b. If $a could be same as $b, the # of modifications
;# will be returned (this may be zero or positive integer.).
;# If $a has no possibility to become $b, undef is returned.
;# In this case, `$a->realpath' must exists.
;# In a modified time check, if ($op & 0x80) is not zero,
;# modified time must be same, e.g., undef is returned when
;# modified time mismatch found.
;# case of ($op & 7) == 3:
;# Same as the case of $op == 2, but no real modification
;# will be performed. This is useful for test mode.
;#
;# and if ($op & 8) is true, `besame' requires mtimes for $a and
;# $b must match.
;#
sub besame ($$$;$) {
my $p = shift; # myself
my $a = shift; # Attrib object
my $b = shift; # Attrib object
my $modify = 0;
my $op;
my $path = undef;
my $key;
my $val;
my $ftp = $p->{via_ftp};
# DEBUG purpose only.
confess("$a must be an Attrib")
unless ref($a) && $a->isa('Fan::Attrib');
confess("$b must be an Attrib")
unless ref($b) && $b->isa('Fan::Attrib');
# Set operation type.
if (@_) {
$op = shift;
} else { # or default operation type.
$op = $p->put_mode ? 1 :
$p->test_mode ? 3 : 2;
}
# Must we check mtime?
my $check_mtime = $op & 8;
$op &= 7;
plog(8, "* besame($a, $b, $op)\n");
# $op == 2 may modify real path attributes.
if ($op == 2) {
my $t = $a->{y_realpath};
$path = $t if $t ne '' && -e $t; # check existence
}
# for logging
my $x = $a->path;
# Types must match.
$key = 'y_type';
$val = exists($b->{$key}) ? $b->{$key} : undef;
if ($a->{$key} ne $val) {
plog(7, "$x: type differs.\n");
return undef;
}
# Check symlink
if ($val eq 'L') {
$key = 'y_linkto';
$val = exists($b->{$key}) ? $b->{$key} : undef;
if ($a->{$key} eq $val) {
plog(8, "$x: symlink check ok.\n");
} elsif ($op == 2 && $path) { # modification is permitted
unlink($path); # type == symlink was checked.
symlink($val, $path);
$a->{$key} = $val;
$modify++;
plog(8, "$x: symlink modify ok.\n");
} elsif ($op == 3) {
$a->{$key} = $val;
$modify++;
plog(8, "$x: symlink will be changed.\n");
} else {
plog(7, "$x: symlink mismatch.\n");
return undef;
}
## return $modify; # no more check is required for symlink.
} elsif ($val eq 'F') { # Check a regular file.
# Size must match, too.
$key = 'y_size';
$val = exists($b->{$key}) ? $b->{$key} : undef;
if (!exists($a->{$key}) || !defined($val)) {
plog(8, "$x: skip size test.\n");
} elsif ($a->{$key} == $val) {
plog(8, "$x: size check ok.\n");
} else {
plog(7, "$x: size differs.\n");
return undef; # this is a critical error
}
# MD5 checksum must match if exists.
$key = 'y_checksum';
$val = exists($b->{$key}) ? $b->{$key} : undef;
if (!exists($a->{$key}) || !defined($val)) {
plog(8, "$x: skip checksum test.\n");
} elsif ($a->{$key} eq $val) {
plog(8, "$x: checksum test ok.\n");
# In this case, MD5CHECKSUM is same, so
# We need not check mtime.
$check_mtime = 0;
} else {
plog(7, "$x: checksum differs.\n");
return undef; # this is a critical error
}
# By default we require mtime check.
my $need_mtime_check = 0;
my $ta;
my $tb;
my $tt;
my $z;
# Undefined modified time means that the attribute was
# filled with FTP LIST information (including ls-lR).
# So, at least one of $a or $b must have modified time.
$key = 'y_mtime';
if (exists($a->{$key}) && exists($b->{$key})) {
$need_mtime_check++;
} elsif (exists($a->{$key})) {
if (!defined($p->ftp_offset) &&
$b->{y_date} =~ /\d\d?:\d\d/ &&
$p->fill_mtime($b)) {
$need_mtime_check++;
} else {
$tt = $ta = $a->{$key} + $p->ftp_offset;
$tb = $b->{y_time0};
$z = $b;
}
} elsif (exists($b->{$key})) {
if (!defined($p->ftp_offset) &&
$a->{y_date} =~ /\d\d?:\d\d/ &&
$p->fill_mtime($a)) {
$need_mtime_check++;
} else {
$ta = $a->{y_time0};
$tt = $tb = $b->{$key} + $p->ftp_offset;
$z = $a;
}
} else { # THIS MUST NOT OCCUR
confess("neither of $a or $b has no mtime");
die; die; die;
}
# check time0 / date before mtime check.
if ($need_mtime_check) {
; # skip this
} elsif ($ta == $tb) {
plog(8, "$x: time0 check ok.\n");
} elsif ($op == 1 && $ta > $tb) {
plog(8, "$x: time0 seems good.\n");
} elsif (date_check($z->date, $tt)) {
plog(8, "$x: time0(date) check ok.\n");
} elsif ($p->fill_mtime($z)) {
$need_mtime_check++; # get mtime o.k., warp to next.
} elsif ($check_mtime) {
plog(8, "$x: time0 check failed.\n"), return undef;
} elsif ($op == 2) {
if ($p->put_mode) { # this is FTP server's file
plog(7, "$x: time0 do nothing, ignored.\n");
} elsif ($path && ! -l $path) {
unless (utime($tb, $tb, $path)) {
warn("utime($path): $!");
return undef;
}
$a->{y_time0} = $tb;
$modify++;
plog(8, "$x: time0 modify ok.\n");
} else {
plog(7, "$x: time0 no file found.\n");
### return undef;
}
} elsif ($op == 3) {
$a->{y_time0} = $val;
$modify++;
plog(8, "$x: mtime will be changed.\n");
} else {
plog(8, "$x: time0 check error.\n"), return undef;
}
#
$key = 'y_mtime';
$val = $b->{$key};
if (!$need_mtime_check) {
; # simply skip this check
} elsif (!exists($a->{$key}) || !defined($val)) {
plog(8, "$x: skip mtime check.\n"); # really?
} elsif ($a->{$key} == $val) {
plog(8, "$x: mtime check ok.\n");
} elsif ($op == 1 && $a->{$key} > $val) {
plog(8, "$x: mtime seems good.\n");
} elsif ($check_mtime) {
plog(8, "$x: mtime check failed.\n"), return undef;
} elsif ($op == 2) {
if ($p->put_mode) { # this is FTP server's file
plog(7, "$x: mtime do nothing, ignored.\n");
} elsif ($path && ! -l $path) {
unless (utime($val, $val, $path)) {
warn("utime($path): $!");
return undef;
}
$a->{$key} = $val;
$modify++;
plog(8, "$x: mtime modify ok.\n");
} else {
plog(7, "$x: mtime no file found, ignored.\n");
### return undef;
}
} elsif ($op == 3) {
$a->{$key} = $val;
$modify++;
plog(8, "$x: mtime will be changed.\n");
} else {
plog(8, "$x: mtime check error.\n"), return undef;
}
}
# Addtional checks are only for $op == 2 || $op == 3.
return 0 unless $op == 2 || $op == 3;
# Check permission.
$key = 'y_perm';
$val = $b->{$key};
if (!exists($a->{$key}) || !defined($val)) {
plog(8, "$x: skip perm test.\n");
} elsif ($a->{$key} == $val) {
plog(8, "$x: perm check ok.\n");
} elsif ($op == 2) {
if ($p->put_mode) { # this is FTP server's file
my $ftp = $p->{via_ftp}; # MUST EXIST
warn("try chmod $path\n") if $LOG >= 5;
if ($ftp->chmod($val, $path)) {
$modify++;
plog(8, "$x: perm modify ok.\n");
} else {
warn("FTP::chmod($path): [".$ftp->error."]\n")
if $LOG >= 6;
# but ignore this error
plog(7, "$x: perm could not modify.\n");
}
} elsif ($path && ! -l $path) {
unless (chmod($val, $path)) {
warn("chmod($path): $!");
return undef;
}
$a->{$key} = $val;
$modify++;
plog(8, "$x: perm modify ok.\n");
} else {
plog(7, "$x: mtime no file found, ignored.\n");
### return undef;
}
} elsif ($op == 3) {
$modify++;
plog(8, "$x: perm will be changed.\n");
} else {
plog(7, "$x: perm check error.\n");
return undef;
}
# Check owner / group
$key = 'y_owner';
$val = $b->{$key};
if ($< || !exists($a->{$key}) || !defined($val)) {
plog(8, "$x: skip owner test.\n");
} elsif ($a->{$key} == $val && $a->{y_group} == $b->{y_group}) {
plog(8, "$x: owner check ok.\n");
} elsif ($op == 2) {
if ($p->put_mode) { # this is FTP server's file
plog(7, "$x: time0 do nothing, ignored.\n");
} elsif ($path) {
my $g = $b->{y_group};
if (!defined($g) && !defined($g = (stat($path))[5])) {
warn("stat($path): $!\n");
return undef;
}
unless (chown($val, $g, $path)) {
warn("chown($path): $!");
return undef;
}
$a->{$key} = $val;
$a->{y_group} = $g;
$modify++;
plog(8, "$x: owner modify ok.\n");
} else {
plog(7, "$x: owner no file found, ignored.\n");
### return undef;
}
} elsif ($op == 3) {
$modify++;
plog(8, "$x: owner will be changed.\n");
} else {
plog(7, "$x: owner check error.\n");
return undef;
}
# DEBUG only: At last, we validate once more.
return undef unless $a->validate;
# result is # of modifications.
$modify;
}
;#
;# date_check returns 1 if check is o.k.
;#
sub date_check ($$) {
my $date = shift;
my $time = shift;
$date =~ s/\s+/ /g || return undef; # maybe null string.
warn("date_check: $time vs [$date]\n") if $LOG > 7;
my($sec, $min, $hour, $day, $month, $year) = gmtime($time);
my $mon = $Fan::Cool::nameofmonth[$month];
$month++;
my $d;
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 =~ / \d\d:\d\d:\d\d \d\d\d\d$/) { # long format
$d = sprintf("%s %d %02d:%02d:%02d %04d", $mon, $day,
$hour, $min, $sec, $year + 1900);
} elsif ($date =~ / \d\d:\d\d$/) { # time
$d = sprintf("%s %d %02d:%02d", $mon, $day, $hour, $min);
} elsif ($date =~ / \d:\d\d$/) {
$d = sprintf("%s %d %d:%02d", $mon, $day, $hour, $min);
} else {
$d = sprintf("%s %d %04d", $mon, $day, $year + 1900);
}
my $result = $date eq $d ? 1 : 0;
warn("date_check: [$d] vs [$date] results $result\n") if $LOG > 7;
$result;
}
;#
;# Calculate offset of server's timezone.
;# Usage:
;# $offset = &calc_offset(time_in_gmt, time_in_local);
;#
sub calc_offset ($$) {
my $exact = shift;
my $wrong = shift;
my $diff = $wrong - $exact;
# $z is the timezone
my $h = int((abs($diff) + 1800) / 3600);
# check offset value
if ($h >= 24) {
warn("calc_offset: diff=$diff seems wrong.\n");
return undef;
}
# debug log
# my $z = ($diff < 0 ? '-' : '+').sprintf("%02d00", $h);
# plog(6, "calc_offset: timezone seems to be $z\n");
# result is the offset value of timezone.
my $offset = 3600 * $h;
$offset = - $offset if $diff < 0;
$offset;
}
;#
;# $p->adjust_offset(time_in_gmt, time_in_local);
;# adjust $p->{'offset'}.
;#
;#
sub adjust_offset ($$$) {
my $self = shift; # Package object.
my $offset = &calc_offset(@_);
unless (defined($offset)) {
warn("adjust_offset: could not find offset.\n") if $LOG > 5;
return undef;
}
unless (defined($self->setval('ftp_offset', $offset))) {
warn("adjust_offset: could not set offset.\n") if $LOG > 5;
return undef;
}
warn("adjust_offset: offset = $offset\n") if $LOG > 5;
1;
}
;#
;# Generate .dirinfo files for the local directory.
;#
sub mkdirinfo ($) {
my $p = shift;
my $dir = $p->local_directory;
# try generate DIR object.
use Fan::DIR;
my $info = Fan::DIR->new(dir_path => $dir);
# check result.
unless (ref($info)) {
carp("DIR($dir) can't be initialized.\n");
return undef;
}
# let's try.
if ($info->update) { # this is a recursive call.
warn("$dir: modified.\n") if $LOG > 5;
} else {
warn("$dir: not modified.\n") if $LOG > 5;
}
# success to update .dirinfo files.
1;
}
;#
;# generate server side scanner.
;# returning Scan object.
;#
sub remote_scanner ($;$) {
my $p = shift; # Fan object.
my $force_ftp = @_ ? shift : 0;
my $scan = undef;
# Check network initialization.
unless ($p->net_init) {
warn("step_synch: can't initialize network");
return undef;
}
# Check index directories.
# SHOULD WE HAVE A NEW FLAG FOR INDEX MODE?
if (!$force_ftp && $p->local_db_directory) { # index mode
unless ($p->step_synch) {
carp("remote_scanner: can't synch step files");
return undef;
}
$scan = Fan::Scan->new(
scan_type => 'INDEX',
scan_index => $p->{newest_index_file},
);
unless (defined($scan)) {
carp("remote_scanner: Can't create Scan(INDEX)");
return undef;
}
}
# Try to get remote lslR file if required.
my $file = $p->lslR_file;
my $copy = $p->lslR_copy;
my $lslR_mode = $file || $copy;
if (!$force_ftp && !defined($scan) && $lslR_mode) {
my $notrans = 0;
my $a = undef;
my $m = 0;
# if we have remote lslR_file.
if ($file ne '') {
my $tail;
($tail) = $file =~ m|([^/]+)$|;
$a = Fan::Attrib->new(
y_type => 'F',
y_path => $file,
y_name => $tail,
);
$p->fill_size($a);
$p->fill_mtime($a);
$m = $a->mtime;
}
# change to absulte if needed.
if ($copy =~ /^[^\/]/) {
$copy = $p->local_directory.'.'.$copy;
}
# check if we should transfer lslR_file or not.
if ($copy eq '') {
$copy = $p->temp_directory."/ls$$";
$copy .= $& if $file =~ /\.(gz|Z)$/;
$p->{tempfiles}->{$copy}++;
} elsif (-f $copy) {
my $y = Fan::Attrib->new(attr_path => $copy);
if (!ref($a)) {
$notrans++;
} elsif ($a->size == $y->size && $y->mtime eq $m) {
$notrans++; # no need to transfer...
}
} elsif (!ref($a)) {
carp("remote_scanner: no remote lslR_file");
return undef;
}
# notrans flags or try to retrieve server's lslR file.
unless ($notrans || $p->get($file, $copy)) {
carp("remote_scanner: can't get $file");
return undef;
}
# try to set modified time of local copy.
if ($m > 0) {
utime($m, $m, $copy); # ignore result.
}
# now, generate scanner.
$scan = Fan::Scan->new(
scan_type => 'LSLR',
scan_lslR => $copy
);
# check result.
unless (defined($scan)) {
carp("remote_scanner: can't create Scan(LSLR)");
return undef;
}
}
# try normal FTP session
if (!defined($scan)) { # normal FTP session
if ($p->load_remote_dirinfo) { # we can load dirinfo?
plog(5, "load dirinfo = yes\n");
}
$scan = Fan::Scan->new(
scan_type => 'FTP',
scan_ftp => $p, # myself
scan_dir => $p->remote_directory,
scan_dirinfo => $p->load_remote_dirinfo
);
unless (defined($scan)) {
carp("remote_scanner: can't create Scan(FTP)");
return undef;
}
}
# additional filters
my $code = $p->put_mode ? \&client_filter : \&server_filter;
unless ($scan->add_filter($code, $p)) {
carp("remote_scanner: can't add filter");
return undef;
}
# additional filters for file uid/gid, file mode
unless ($p->put_mode) {
unless ($scan->add_filter(\&changer_filter, $p)) {
carp("remote_scanner: can't add changer");
return undef;
}
}
# information log...
warn("remote directory = ".$p->remote_directory."\n") if $LOG >= 5;
# $scan is defined on success
$scan;
}
;#
sub local_scanner ($;$) {
my $p = shift; # Fan object
my $force_local = @_ ? shift : !$p->use_master_db;
my $dir = $p->master_db_directory;
my $scan = undef;
# local index file can be used for local scanner...
if (!$force_local && $dir ne '' && -d $dir) {
my $farm = Fan::Farm->new($dir);
if (defined($farm) && $farm->{pim_index_max} > 0) {
my $index = "$dir/index.$farm->{pim_index_max}";
$scan = Fan::Scan->new(
scan_type => 'INDEX',
scan_index => $index
);
}
}
# local side scanner
if (!defined($scan)) {
$scan = Fan::Scan->new(
scan_type => 'LOCAL',
scan_dir => $p->local_directory,
);
}
unless (defined($scan)) {
carp("local_scanner: can't create Scan(LOCAL)");
return undef;
}
# additional filters
my $code = $p->put_mode ? \&server_filter : \&client_filter;
unless ($scan->add_filter($code, $p)) {
carp("local_scanner: can't add filter");
return undef;
}
# additional filters for file uid/gid, file mode
if ($p->put_mode) {
unless ($scan->add_filter(\&changer_filter, $p)) {
carp("remote_scanner: can't add changer");
return undef;
}
}
# information log...
warn("local directory = ".$p->local_directory."\n") if $LOG >= 5;
#
$scan;
}
;#
sub server_filter {
my $y = shift; # Fan::Attrib object.
my $p = shift; # Argument == Fan object.
my $t = $y->type;
my $x = $y->path;
if ($t eq 'D' || $t eq 'U') {
unless (&{$p->transfer_directory}($x.'/')) {
plog(7, "$x/... server file ignored (transfer)\n");
return 0;
}
unless (&{$p->override_directory}($x.'/')) {
plog(7, "$x/... server file ignored (override)\n");
return 0;
}
} elsif ($t eq 'F' || $t eq 'L') {
unless (&{$p->transfer_file}($x)) {
plog(7, "$x... server file ignored (transfer)\n");
return 0;
}
unless (&{$p->override_file}($x)) {
plog(7, "$x... server file ignored (override)\n");
return 0;
}
}
plog(8, "$t $x... server file found\n") if defined($x);
1;
}
;#
sub client_filter {
my $y = shift; # Fan::Attrib object.
my $p = shift; # Argument == Fan object.
my $t = $y->type;
my $x = $y->path;
if ($t eq 'D' || $t eq 'U') {
unless (&{$p->override_directory}($x.'/')) {
plog(7, "$x/... client file ignored (override)\n");
return 0;
}
} elsif ($t eq 'F' || $t eq 'L') {
unless (&{$p->override_file}($x)) {
plog(7, "$x... client file ignored (override)\n");
return 0;
}
}
plog(8, "$t $x... client file found\n") if defined($x);
1;
}
;#
sub changer_filter {
my $y = shift; # Fan::Attrib object.
my $p = shift; # Argument == Fan object.
my $t = $y->type;
# change file mode
if ($t eq 'D' || $t eq 'U') {
my $mode = $p->override_directory_mode;
if ($p->override_directory_mode) {
$mode = oct($p->override_directory_mode);
} elsif (defined($y->perm)) {
$mode = $y->perm; # not in octal
} elsif ($p->default_directory_mode) {
$mode = oct($p->default_directory_mode);
} else {
$mode = 0755;
}
$y->perm($mode);
} elsif ($t eq 'F') {
my $mode;
if ($p->override_file_mode) {
$mode = oct($p->override_file_mode);
} elsif (defined($y->perm)) {
$mode = $y->perm; # not octal
} elsif ($p->default_file_mode) {
$mode = oct($p->default_file_mode);
} else {
$mode = 0644;
}
$y->perm($mode);
}
# only super user can change owner
if ($< == 0 && ($t eq 'D' || $t eq 'U' || $t eq 'F')) {
my $uid;
my $gid;
if (defined($uid = get_uid($p->override_file_uid))) {
; # o.k.
} elsif (defined($uid = get_uid($y->owner))) {
; # o.k.
} elsif (defined($uid = get_uid($p->default_file_uid))) {
; # o.k.
} else {
$uid = 0;
}
$y->owner($uid);
if (defined($gid = get_gid($p->override_file_gid))) {
; # o.k.
} elsif (defined($gid = get_gid($y->group))) {
; # o.k.
} elsif (defined($gid = get_gid($p->default_file_gid))) {
; # o.k.
} else {
$gid = (split(/\s+/, $)))[0];
}
$y->group($gid);
}
# and we always return success
1;
}
;#
sub get_uid {
my $uid = shift;
$uid eq '' ? undef : $uid =~ /^\d+$/ ? $& : (getpwnam($uid))[2];
}
;#
sub get_gid {
my $gid = shift;
$gid eq '' ? undef : $gid =~ /^\d+$/ ? $& : (getgrnam($gid))[2];
}
;#
sub scan_any ($$) {
my $p = shift;
my $scan = shift;
my $x;
while (defined($x = $scan->get)) {
my $t = $x->type;
print $x->path."\n" if $t ne 'U' && $t ne '.';
}
1;
}
;#
sub scan_remote ($) {
my $p = shift;
my $scan = $p->remote_scanner;
unless (ref($scan)) {
carp("scan_remote: can't create Scan object");
return undef;
}
$p->scan_any($scan);
}
;#
sub scan_local ($) {
my $p = shift;
my $scan = $p->local_scanner;
unless (ref($scan)) {
carp("scan_local: can't create Scan object");
return undef;
}
$p->scan_any($scan);
}
;#
sub update_master ($) {
my $p = shift;
my $dir = $p->master_db_directory;
my $farm = Fan::Farm->new($dir);
unless (defined($farm)) {
carp("update_master: can't create Farm");
return undef;
}
unless ($farm->generate($p->local_directory)) {
carp("update_master: can't update index");
return undef;
}
unless ($farm->normalize) {
carp("update_master: can't normalize farm");
return undef;
}
unless ($farm->genindex) {
carp("update_master: can't generate local index");
return undef;
}
1;
}
;# end of Fan module
syntax highlighted by Code2HTML, v. 0.9.1