;#
;# Copyright (c) 1996, 1997 Ikuo Nakagawa.
;# All rights reserved.
;#
;# $Id: param.pl,v 1.10 1997/06/02 00:52:43 ikuo Exp $
;#
;# Description:
;#   Define ftp-server first, and merge parameters in order:
;#	1. initial parameters	$assoc{'INIT'}
;#	2. default parameters	$assoc{'DEFAULT'}
;#	3. server parameters	$assoc{'SERVER:server-name'}
;#	4. package parameters	$assoc{'PACKAGE:package-name'}
;#	5. option parameters	$assoc{'OPTION'}
;#
package param;

;# load module
require "log.pl";

;# Prototypes
;# sub init(*);
;# sub load($;$);
;# sub check(\%);
;# sub dump(\%);
;# sub dumpall();
;# sub get($);
;# sub gen_match(@);
;# sub gen_subst(@);

;#
;# Get system parameters, such as hostname, user/group ids for ftp,
;# current user-id, and so on.
;#
sub init {
 local(*arg) = @_;
 my $hostname = `hostname`;
 my $dir = (getpwnam('ftp'))[$[ + 7];
 my $name = getpwuid($<);
 my $md5_program
  = -x "/sbin/md5" ? "/sbin/md5"
  : -x "/usr/local/bin/md5" ? "/usr/local/bin/md5"
  : -x "/usr/bin/md5" ? "/usr/bin/md5"
  : undef;

 chomp($hostname);
 $hostname = "localhost" if $hostname eq '';

 ;# initial parameters
 $assoc{'INIT'} = {
  'prefix'			=> $main::prefix,
  'alternate-package'		=> undef,
  'debug'			=> 0,
  'log-priority'		=> undef,
  'log-label'			=> undef,
  'change-directory'		=> 0,
  'use-dirinfo'			=> undef,
  'load-remote-dirinfo'		=> undef,
  'load-local-dirinfo'		=> undef,
  'store-local-dirinfo'		=> undef,
  'local-hostname'		=> $hostname,
  'ftp-debug'			=> 0,
  'ftp-timeout'			=> 60,
  'ftp-bindaddress'		=> '',
  'ftp-passive'			=> 0,
  'ftp-server'			=> '',
  'ftp-gateway'			=> '',
  'ftp-user'			=> 'anonymous',
  'ftp-pass'			=> $name.'@'.$hostname,
  'ftp-group'			=> '',
  'ftp-gpass'			=> '',
  'ftp-idle'			=> undef,
  'ftp-max-idle'		=> undef,
  'ftp-list-method'		=> 'stat',
  'lslR-file'			=> '',
  'lslR-map'			=> '',
  'lsparse-debug'		=> 0,
  'compare-stat'		=> 1,
  'check-mtime'			=> 1,
  'symlink-mode'		=> '', # for 4.4BSD symlink
  'file-uid'			=> undef,	# backward compatibility
  'file-gid'			=> undef,	# backward compatibility
  'file-mode'			=> undef,	# backward compatibility
  'directory-mode'		=> undef,	# backward compatibility
  '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',
  'umask'			=> '022',
  'unlink'			=> 'yes',
  'unlink-limit'		=> 0,
  'md5-program'			=> $md5_program,
  'backup-suffix'		=> '~',
  'test-mode'			=> 0,
  'remote-timezone'		=> 0,
  'home-directory'		=> defined($dir) ? $dir : '',
  'lock-directory'		=> "/tmp",
  'temp-directory'		=> "/tmp",
  'local-directory'		=> '',
  'remote-directory'		=> '',
  'regexp'			=> undef,
  'transfer-file-regexp'	=> undef,
  'transfer-directory-regexp'	=> undef,
  'override-regexp'		=> undef,
  'override-file-regexp'	=> undef,
  'override-directory-regexp'	=> undef,
  'follow-symlink-regexp'	=> undef,
  'symlink-map'			=> undef,
  'parse-realpath'		=> undef,
  'xfertype'			=> 'GET'
 };

 ;# parsing command line options
 my $i = \%{$assoc{'INIT'}};
 my $p = \%{$assoc{'OPTION'}};

 ;# option format is "--tag=value"
 while (@arg && $arg[$[] =~ s/^--//) {
  local($_) = shift(@arg);
  my($key, $val) = /\s*=\s*/ ? ($`, $') : ($_, 1);
  if (exists($i->{$key})) {
   $p->{$key} = $val;
  } else {
   log::putl("WARNING", "$key: no such parameter, ignored.");
  }
 }

 ;# setup DEFAULT parameters
 &load('default', 'DEFAULT');
}

;# Load configuration file and set parameters.
;# Merge parameters and create new %param assoc array.
;# define ftp-server first, and merge parameters in order:
;#   1. initial parameters	$assoc{'INIT'}
;#   2. default parameters	$assoc{'DEFAULT'}
;#   3. server parameters	$assoc{'SERVER:server-name'}
;#   4. package parameters	$assoc{'PACKAGE:package-name'}
;#   5. option parameters	$assoc{'OPTION'}
sub load {
 my($y, $key) = @_; # $y is package name, $key is assoc key
 local($_, *FILE);
 local($p, $q, $s, $x);

 ;# We refer initial parameters for the existence of a parameter
 my $i = \%{$assoc{'INIT'}};

 ;# make prefix value
 my $prefix =
  defined($assoc{'OPTION'}->{'prefix'}) ? $assoc{'OPTION'}->{'prefix'} :
  defined($assoc{'INIT'}->{'prefix'}) ? $assoc{'INIT'}->{'prefix'} :
  defined($main::prefix) ? $main::prefix :
  "/usr/local/lib/ftpmirror";

 ;# clean assoc first
 undef %param;

 ;# Open configuration file
 if (open(FILE, $y) || open(FILE, "$prefix/config/$y")) {

  ;# Define key of assoc array
  $key = "PACKAGE:$y" if !defined($key) || $key eq '';

  ;# Set reference for assoc and package name
  ($p = \%{$assoc{$key}})->{'package'} = $y;

  ;#  reading lines
  while (<FILE>) {
   s/^\s+//; s/\s+$//; next if /^$/ || /^#/;

   my($tag, $val) =
    /^undef\s+/ ? ($', undef) :
    /\s*\+=\s*/ ? ($`, "\n".$') :
    /\s*=\s*/ ? ($`, $') : ($_, 1);

   if ($tag eq 'package') {
    ($p = \%{$assoc{"PACKAGE:$val"}})->{'package'} = $val;
   } elsif ($tag eq 'server') {
    ($p = \%{$assoc{"SERVER:$val"}})->{'server'} = $val;
   } elsif ($tag eq 'load-package') {
    if (defined($q = $assoc{"PACKAGE:$val"}) && ref($q) eq 'HASH') {
     for $x (keys %{$q}) {
      next if $x eq 'package';
      next if $x eq 'alternate-package';
      $p->{$x} = $q->{$x};
     }
    } else {
     log::putl("NOTICE", "$val: no such package defined, ignored.");
    }
   } elsif (exists($i->{$tag})) {
    if ($val =~ /^\n/ && defined($p->{$tag})) {
     $p->{$tag} .= $val;
    } else {
     $p->{$tag} = $val;
    }
   } else {
    log::putl("NOTICE", "$tag: no such parameter, ignored.");
   }
  }
  close(FILE);
 }

 ;# Do nothing any more if $key eq 'DEFAULT'.
 return \%{$assoc{'DEFAULT'}} if $key eq 'DEFAULT';

 ;# Check existence of the package
 return undef if !exists($assoc{"PACKAGE:$y"});

 ;# Define ftp-server first.
 for $key ("INIT", "DEFAULT", "PACKAGE:$y", "OPTION") {
  $s = $p->{'ftp-server'} if defined($p = $assoc{$key})
   && ref($p) eq "HASH" && exists($p->{'ftp-server'});
 }

 ;# Check ftp-server name.
 return undef if !defined($s);

 ;# Merge parameters
 for $key ("INIT", "DEFAULT", "SERVER:$s", "PACKAGE:$y", "OPTION") {
  defined($p = $assoc{$key}) && ref($p) eq "HASH" || next;
  for $x (keys %{$p}) {
   if ($p->{$x} =~ /^\n/) {
    ($param{$x} .= $p->{$x}) =~ s/^\n+//;
   } else {
    $param{$x} = $p->{$x};
   }
  }
 }

 ;# always success
 \%param;
}

;# check parameters
sub check {
 my($p) = @_;
 my($n, $y); # $y is package name
 local($_);

 ;# Check package name.
 log::putl("WARNING", "$y: No pacakge name."),
  return undef if ($y = $p->{'package'}) eq '';

 ;# Log priority
 if (!defined($p->{'log-priority'})) {
  $p->{'log-priority'} = $p->{'debug'} ? "INFO" : "NOTICE";
 }
 $p->{'log-priority'} = log::level($p->{'log-priority'})
  if $p->{'log-priority'} !~ /^\d+$/;

 ;# Check required parameters.
 for (qw(ftp-server ftp-user ftp-pass remote-directory local-directory
         lock-directory temp-directory)) {
  if ($p->{$_} eq '') {
   log::putl("WARNING", "$y: No $_ parameter."), return undef;
  }
 }

 ;# check directory existence
 if (! -d $p->{'lock-directory'}) {
  log::putl("WARNING", "$p->{'lock-directory'}: not found"), return undef;
 }
 if (! -d $p->{'temp-directory'}) {
  log::putl("WARNING", "$p->{'temp-directory'}: not found"), return undef;
 }

 ;# Some pattern match routine
 if (!defined($p->{'transfer-regexp'}) && defined($p->{'regexp'})) {
  $p->{'transfer-regexp'} = $p->{'regexp'};
 }
 delete $p->{'regexp'}; # obsolete

 ;# default value of *-dirinfo
 if ($p->{'use-dirinfo'}) {
  $p->{'load-remote-dirinfo'} = 1 if !defined($p->{'load-remote-dirinfo'});
  $p->{'load-local-dirinfo'} = 1 if !defined($p->{'load-local-dirinfo'});
  $p->{'store-local-dirinfo'} = 1 if !defined($p->{'store-local-dirinfo'});
 }

 ;#
 if (!defined($p->{'transfer-directory-regexp'}) &&
     !defined($p->{'transfer-file-regexp'}) &&
     defined($p->{'transfer-regexp'})) {
  $p->{'transfer-directory-regexp'} = $p->{'transfer-regexp'};
  $p->{'transfer-file-regexp'} = $p->{'transfer-regexp'};
 }
 delete $p->{'transfer-regexp'};

 ;# dirinfo?
 if ($p->{'load-remote-dirinfo'}) {
  my $z = $p->{'transfer-file-regexp'};
  $p->{'transfer-file-regexp'} = '!/\/\.dirinfo/'.($z eq '' ? '' : "\n$z");
 }

 ;#
 if (!defined($p->{'override-directory-regexp'}) &&
     !defined($p->{'override-file-regexp'}) &&
     defined($p->{'override-regexp'})) {
  $p->{'override-directory-regexp'} = $p->{'override-regexp'};
  $p->{'override-file-regexp'} = $p->{'override-regexp'};
 }
 delete $p->{'override-regexp'};

 ;# dirinfo?
 if ($p->{'store-local-dirinfo'}) {
  my $z = $p->{'override-file-regexp'};
  $p->{'override-file-regexp'} = '!/\/\.dirinfo/'.($z eq '' ? '' : "\n$z");
 }

 ;# `change-directory = 1' is required if follow-symlink-regexp is defined.
 $p->{'change-directory'} = 1 if defined($p->{'follow-symlink-regexp'});

 ;# Generate match routine
 for (qw(override-directory override-file transfer-directory transfer-file
  follow-symlink)) {
  defined($p->{$_} = &gen_match(split("\n", $p->{"$_-regexp"})))
   || do { log::putl("WARNING", "$y: Can't define `$_'"), return undef };
 }

 ;# Generate substitution routine
 if ($p->{'lslR-map'} ne '') {
  defined($p->{'lslR-subst'} = &gen_subst(split("\n", $p->{'lslR-map'})))
   || do { log::putl("WARNING", "lslR-map: bad subst rules"), return undef };
 }
 if ($p->{'symlink-map'} ne '') {
  defined($p->{'symlink-subst'} = &gen_subst(split("\n", $p->{'symlink-map'})))
   || do { log::putl("WARNING", "symlink-map: bad subst rules"), return undef };
 }

 ;# ftp home directory
 if (defined($p->{'home-directory'})) {
  if ($p->{'home-directory'} !~ m%^/%) {
   log::putl("WARNING", "home-directory must be absolute."), return undef;
  }
  $p->{'home-directory'} =~ s%/*$%/%;
 }

 ;# for local side directory
 if ($p->{'local-directory'} =~ s%^\~/%%) {
  $p->{'local-directory'} = $p->{'home-directory'}.$p->{'local-directory'};
 }

 ;# for backward compatibility
 for $n (qw(file-uid file-gid file-mode directory-mode)) {
  defined($p->{$n}) && $p->{$n} ne '' || next;
  if (!defined($p->{"override-$n"})) {
   $p->{"override-$n"} = $p->{$n};
   delete $p->{$n};
  }
 }

 ;# octal values
 for $n (qw(override-file-mode override-directory-mode
	    default-file-mode default-directory-mode
	    symlink-mode directory-mode umask)) {
  defined($p->{$n}) && $p->{$n} ne '' || next;
  $_ = $p->{$n};
  /^\d+$/ || do {
   log::putl("WARNING", "illegal value for $n: $_"), return undef;
  };
  $_ = '0'.$_ if !/^0/;
  $p->{$n} = eval;
 }

 ;# unlink mode
 my $unlink = 0;
 $unlink = 2 if $p->{'unlink'} =~ /^([1-9][0-9]*|yes|true)$/i;
 $unlink = 1 if $p->{'unlink'} eq 'rename';
 $p->{'unlink-type'} = $unlink;

 ;# consider offset of timezone
 my $offset = 0;
 if (defined($p->{'remote-timezone'})) {
  if ($p->{'remote-timezone'} =~ /^(\+|-)(\d\d?)(\d\d)$/) {
   my($sig, $h, $m) = ($1, $2, $3);
   $h =~ s/^0//; $m =~ s/^0//;
   $offset = 3600 * $h + 60 * $m;
   $offset = - $offset if $sig eq '-';
  }
 }
 $p->{'offset'} = $offset;

 ;# parameters in ftputil.pl
 for $x (qw(debug timeout bindaddress server gateway
	 user pass group gpass passive idle max-idle)) {
  my $y = "ftp-$x";
  $x =~ s/-/_/g;
  eval "\$ftp::$x = defined(\$p->{'$y'}) ? \$p->{'$y'} : undef;";
  die $@ if $@;
 }

 ;# parameters in lsparse.pl
 for $x (qw(debug)) {
  my $y = "lsparse-$x";
  $x =~ s/-/_/g;
  eval "\$lsparse::$x = defined(\$p->{'$y'}) ? \$p->{'$y'} : undef;";
  die $@ if $@;
 }

 ;# for dirinfo
 $p->{'dirinfo-md5-program'} = $p->{'md5-program'}
  if defined($p->{'md5-program'});

 ;# parameters in dirinfo.pl
 for $x (qw(debug md5-program)) {
  my $y = "dirinfo-$x";
  $x =~ s/-/_/g;
  eval "\$dirinfo::$x = defined(\$p->{'$y'}) ? \$p->{'$y'} : undef;";
  die $@ if $@;
 }

 ;# success
 1;
}

;# dump parameters for specified package
sub dump {
 my($p) = @_;
 my $x;

 for $x (sort keys %{$p}) {
  if ($p->{$x} =~ /\n/) {
   print " $x:\n";
   my @list = split(/\n/, $p->{$x});
   my $y;
   for $y (@list) {
    print "  $y\n";
   }
  } else {
   print " $x: $p->{$x}";
   if ($x =~ /(^|-)(umask|mode)$/ && $p->{$x} =~ /^[1-9]\d*$/) {
    printf " (0%o)", $p->{$x}
   }
   print "\n";
  }
 }
 1;
}

;# dump all parameters
sub dumpall {
 my($p, $x, $y);

 for $x (sort keys %assoc) {
  defined($p = $assoc{$x}) && ref($p) eq "HASH" || next;
  print "\n+ $x\n";
  for $y (sort keys %{$p}) {
   print "  $y = $p->{$y}\n";
  }
 }
 1;
}

;#
sub get {
 local($_) = @_;

 exists($param{$_}) ? $param{$_} : undef;
}

;# make pattern match subroutine
sub gen_match {
 local($_);
 my($default, $exp, $s, $func);

 $default = 1;
 $s = "\$func = sub {\n\tlocal(\$_) = \@_;\n";

 for $exp (@_) {
  my($type, $use_regexp);

  $_ = $exp;
  $type = s/^!// ? 0 : 1;

  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";

 ;# evaluate subroutine definition
 eval($s) || do {
  log::putl("WARNING", "Fail to eval match routine: $@"), return undef;
 };

 ;# success
 $func;
}

;# make pattern substitute subroutine
sub gen_subst {
 local($_);
 my($exp, $s, $func);

 $s = "\$func = sub {\n\tlocal(\$_) = \@_;\n";

 for $exp (@_) {
  if ($exp =~ m,^s/,) {
   $s .= "\t$exp;\n";
  } elsif ($exp =~ m,^/,) {
   $s .= "\ts$exp;\n";
  } else {
   $s .= "\ts/$exp/;\n";
  }
 }
 $s .= "\t\$_;\n}\n";

 ;# evaluate subroutine definition
 eval($s) || do {
  log::putl("WARNING", "Fail to eval match routine: $@"), return undef;
 };

 ;# success
 $func;
}

;# success on this package
1;