ftpmirror-1.96/ 40755 1751 1750 0 7031563577 11646 5ustar ikuouserftpmirror-1.96/Fan/ 40755 1751 1750 0 7031563575 12350 5ustar ikuouserftpmirror-1.96/Fan/Attrib/ 40755 1751 1750 0 7031563566 13575 5ustar ikuouserftpmirror-1.96/Fan/Attrib/Attrib.pm100644 1751 1750 46173 7006023062 15470 0ustar ikuouser;# ;# 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: Attrib.pm,v 1.24 1999/10/28 10:32:18 ikuo Exp $ ;# package Fan::Attrib; use strict; use vars qw($VERSION $LOG $tzoff @nameofmonth %nametomonth @accept %escape $regexp_month $regexp_t %y_keys $n_obj $max_obj $seq_obj); ;# modules... use POSIX qw(time_h); use Carp; use AutoLoader 'AUTOLOAD'; ;# this is alpha version... $VERSION = '0.02'; ;# initialize counters. BEGIN { $LOG = 5; $n_obj = $max_obj = $seq_obj = 0; } ;# show counters if requried. END { if ($LOG > 5) { warn("Attrib status summary report:\n"); warn(" total $seq_obj object created\n"); warn(" maximum # of objects are $max_obj\n"); warn(" remaining objects are $n_obj\n"); } } ;# offset time of local timezone. $tzoff = 86400 - mktime(gmtime(86400)); ;# name 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); $regexp_t = '(\d+:\d+:\d+\s+\d\d\d\d)|(\d\d\d\d)|(\d+:\d+)'; ;# Encode / decode path names ;# We must encode, at least, EQUAL, spaces and non printable charactors. ;# Off course, '%' itself must also be encoded. @accept = ('*', '+', '-', '.', ',', '@', '_', '0'..'9', 'A'..'Z', 'a'..'z', '/', '~'); @escape{@accept} = @accept; ;# initialize @escape for (my $i = 0; $i < 256; $i++) { my $c = pack("C", $i); $escape{$c} = sprintf("%%%02x", $i) if !defined($escape{$c}); } ;# keys we should treat. %y_keys = ( y_flag => 0x01, y_type => 0x02, y_name => 0x01, y_path => 0x01, y_realpath => 0x01, y_perm => 0x01, y_owner => 0x01, y_group => 0x01, y_size => 0x01, y_mtime => 0x09, y_time0 => 0x01, y_date => 0x01, y_checksum => 0x01, y_linkto => 0x01, ); ;# generate basic sub routines ;# from y_keys... for my $key (keys %y_keys) { next if 0x08 & $y_keys{$key}; my $f = $key; $f =~ s/^y_//; my $sub = <<"END"; sub $f (\$;\$) { my \$y = shift; \$y->{$key} = shift if \@_; \$y->{$key} } END eval $sub; die $@ if $@; } ;# sub debug ($@) { local $_; grep((print STDERR $_), @_) if $LOG >= shift; } ;# A special marker for AutoSplit. 1; __END__ ;# destroy a Attrib object. sub DESTROY ($) { my $y = shift; # count down # of objects. $n_obj--; # debug log... if ($LOG > 5) { my $t = $y->type; $t .= ' '.$y->name if $t ne '.' && $t ne 'U'; carp("Attrib DESTROYING $y ($t)") if $LOG > 5; } } ;# ;# creat a Attrib new object. ;# attr_path => /where/file/exists or ;# attr_line => attribute line or ;# attr_list => hogehoge or ;# dictionary... ;# ;# attr_keys => reference to a hash $p. ;# by default, \%y_keys is used. ;# ;# An Attrib object has some of following values. ;# y_type ;# y_name ;# y_path ;# y_realpath ;# y_perm ;# y_owner ;# y_group ;# y_size ;# y_time0 ;# y_date ;# y_checksum ;# y_linkto ;# sub new ($%) { my $this = shift; my $class = ref($this) || $this; my %params = @_; # Bless myself. my $y = bless {}, $class; ref($y) or return undef; # Count up # of objects. $seq_obj++; $n_obj++; $max_obj = $n_obj if $max_obj < $n_obj; # Select initializer if (defined($params{attr_path})) { # from a real file $y->from_path($params{attr_path}) or return undef; } elsif (defined($params{attr_line})) { # from a line $y->from_line($params{attr_line}) or return undef; } elsif (defined($params{attr_list})) { # from ls format $y->from_list($params{attr_list}) or return undef; } else { # from %params for my $tag (keys %params) { $y->{$tag} = $params{$tag} if $tag =~ /^y_/; } } # Can we trust this? $y && $y->validate or return undef; # For debugging purpose if ($LOG > 5) { my $t = $y->type; $t .= ' '.$y->name if $t ne '.' && $t ne 'U'; carp("Attrib CREATING $y ($t)"); } # Return this object. $y; } ;# encoder sub attr_encode ($) { local $_ = shift; s/./$escape{$&}/g; $_; } ;# decoder sub attr_decode ($) { local $_ = shift; s/\%(..)/pack("H*", $1)/eg; $_; } ;# get mtime / change mtime (and also change modified time). sub mtime ($;$) { my $y = shift; if (@_) { $y->{y_mtime} = &get_mtime(shift); } $y->{y_mtime}; } ;# convert mtime string to GMT time value. sub get_mtime ($) { local $_ = shift; /^(\d\d\d\d)(\d\d)(\d\d)(\d\d)(\d\d)(\d\d)$/ && return mktime($6, $5, $4, $3, $2 - 1, $1 - 1900) + $tzoff; /^\d+$/ && return $_; warn("get_mtime: wrong format") if $LOG > 5; return undef; } ;# convert GMT time value to MDTM format sub gmt2mdtm ($) { local $_ = shift; defined($_) && /^\d+$/ or return undef; my @t = reverse((gmtime($_))[0..5]); $t[0] += 1900; $t[1]++; sprintf("%04d%02d%02d%02d%02d%02d", @t); } ;# clean up any y_* entries sub cleanup ($) { my $y = shift; for my $t (keys %{$y}) { delete($y->{$t}) if $t =~ /^y_/; } $y; } ;# ;# Validate an Attrib object. ;# If any unexpected case occurs, validate returns undef. ;# sub validate ($) { my $y = shift; my $t = $y->{y_type}; # for type abbrev. # debug log debug(8, "* validate $y\n"); # check type first. if (!defined($t)) { # type must be defined. confess("$y has no type, panic..."); } elsif ($t !~ /^[.DFLU]$/) { # normal types carp("$y has wrong type: $t"); return undef; } else { debug(8, " check ok: type = $t\n"); } # terminator is always success. return 1 if $t eq '.'; # check relative pathname if exists. if (!defined($y->{y_path})) { # anything is ok debug(8, " check ok: no path\n"); } else { debug(8, " check ok: path = $y->{y_path}\n"); } # check real pathname if exists. if (!defined($y->{y_realpath})) { # anything is ok debug(8, " check ok: no realpath\n"); } else { debug(8, " check ok: realpath = $y->{y_realpath}\n"); } # check of the type UP stair. if (!defined($y->{y_name})) { if ($t eq 'U') { debug(8, " check ok: no name (type U)\n"); } else { carp("$y has no name"); return undef; } } else { my $n = $y->{y_name}; # invalid name causes security problems... if ($n ne '' && $n ne '..' && $n !~ /\//) { debug(8, " check ok: name = $n\n"); } else { carp("$y has wrong name: $n"); return undef; } } # check flags if exists if (!defined($y->{y_flag})) { debug(8, " check ok: no flag\n"); } elsif ($y->{y_flag} =~ /^[-+=!]?$/) { debug(8, " check ok: flag = $y->{y_flag}\n"); } else { carp("$y has wrong flag: $y->{y_flag}"); return undef; } # check size if exists if (!defined($y->{y_size})) { debug(8, " check ok: no size\n"); } elsif ($y->{y_size} =~ /^\d+$/) { debug(8, " check ok: size = $y->{y_size}\n"); } else { carp("$y has wrong size: $y->{y_size}"); return undef; } # check checksum values if (!defined($y->{y_checksum})) { debug(8, " check ok: no checksum\n"); } elsif ($y->{y_checksum} =~ /^[a-f0-9]{32}$/) { debug(8, " check ok: checksum = $y->{y_checksum}\n"); } else { carp("$y has wrong checksum: $y->{y_checksum}"); return undef; } # check linkto if (!defined($y->{y_linkto}) && $t eq 'L') { carp("$y has no linkto (type L)"); return undef; } elsif (!defined($y->{y_linkto})) { debug(8, " check ok: no linkto\n"); } else { debug(8, " check ok: linkto = $y->{y_linkto}\n"); } # check permission if exists if (!defined($y->{y_perm})) { debug(8, " check ok: no perm\n"); } elsif ($y->{y_perm} =~ /^\d+$/) { debug(8, " check ok: perm = $y->{y_perm}\n"); } else { carp("$y has wrong perm: $y->{y_perm}"); return undef; } # check owner if (!defined($y->{y_owner})) { debug(8, " check ok: no owner\n"); } elsif ($y->{y_owner} =~ /^[-_\w]+$/) { debug(8, " check ok: owner = $y->{y_owner}\n"); } else { carp("$y has wrong owner: $y->{y_owner}"); return undef; } # check group if (!defined($y->{y_group})) { debug(8, " check ok: no group\n"); } elsif ($y->{y_group} =~ /^[-_\w]+$/) { debug(8, " check ok: group = $y->{y_group}\n"); } else { carp("$y has wrong group: $y->{y_group}"); return undef; } # check modification time if (defined($y->{y_mtime})) { if ($y->{y_mtime} =~ /^\d+$/) { debug(8, " check ok: mtime = $y->{y_mtime}\n"); } else { carp("$y has wrong mtime: $y->{y_mtime}"); return undef; } } elsif (defined($y->{y_time0})) { if ($y->{y_time0} =~ /^\d+$/) { debug(8, " check ok: time0 = $y->{y_time0}\n"); } else { carp("$y has wrong time0: $y->{y_time0}"); return undef; } } else { # no time information debug(8, " check ok: no time information\n"); } # one more debug log debug(8, " validation ok.\n"); # validation o.k. 1; } ;# ;# Compare($x, $y) compares two references for y-structure. ;# This routine returns ;# -1 if $x < $y ;# 1 if $x > $y; ;# 0 otherwise ($x == $y). ;# Both of $x and $y must have y_path parameter. ;# sub compare ($$) { my $x = shift; my $y = shift; # DEBUG purpose only. confess("x=$x must be an Fan::Attrib") unless ref($x) && $x->isa('Fan::Attrib'); confess("y=$y must be an Fan::Attrib") unless ref($y) && $y->isa('Fan::Attrib'); # $z->{y_type} eq '.' means "$z is very large". return 0 if $x->{y_type} eq '.' && $y->{y_type} eq '.'; return -1 if $y->{y_type} eq '.'; # == ($x < $y) return 1 if $x->{y_type} eq '.'; # == ($x > $y) # Temporary pathnames are required to use `cmp' operator. my $z; for $z ($x, $y) { if (!defined($z->{y_temp})) { # DEBUG purpose only. confess("$z has no path") if !defined($z->{y_path}); $z->{y_temp} = $z->{y_path}; $z->{y_temp} =~ y|/|\001|; $z->{y_temp} .= "\001\377" if $z->{y_type} eq 'U'; } } # Now, we can compare with `cmp'. return $x->{y_temp} cmp $y->{y_temp}; } ;# ;# Copy y-structure values from $b to $a. ;# sub copyfrom ($$;$) { my $a = shift; my $b = shift; my $override = @_ ? shift : 0; for my $i (keys %{$b}) { if ($i =~ /^y_/ && ($override || !exists($a->{$i}))) { $a->{$i} = $b->{$i} } } $a; } ;# ;# sub duplicate ($) { my $a = shift; $a->new(%{$a}); } ;# sub to_line ($) { my $y = shift; my $f = $y->{y_flag}; my $t = $y->{y_type}; my $b = ''; # for buffer my $x; # for any return $f.$t if $t eq 'U' || $t eq '.'; if (defined($x = $y->{y_perm})) { $b .= sprintf(" p=%04o", $x); } if (defined($x = $y->{y_owner})) { $b .= " o=$x"; $b .= ".".$x if defined($x = $y->{y_group}); } if (defined($x = $y->{y_mtime})) { $b .= " m=$x"; } if ($t eq 'L' && defined($x = $y->{y_linkto})) { $b .= " l=".attr_encode($x); } if ($t eq 'F') { $b .= " s=$x" if defined($x = $y->{y_size}); if ($x > 0) { $b .= " c=$y->{y_checksum}" if defined($x = $y->{y_checksum}); } } $f.$t.$b." ".attr_encode($y->{y_name}); } ;# ;# sub fill_checksum ($) { my $y = shift; # Attrib if ($y->{y_type} eq 'F' && -f $y->{y_realpath}) { use Fan::MD5; $y->{y_checksum} = MD5File($y->{y_realpath}); } 1; } ;# ;# sub fill ($;$) { my $y = shift; # hash reference my $realpath = @_ ? shift : $y->{y_realpath}; # real pathname # no need to fill out if ($y->{y_type} eq '.' || $y->{y_type} eq 'U') { return $y; # good. return myself. } # get file status... my @s; if ((@s = lstat($realpath)) == 0) { warn("lstat($realpath): $!\n") if $LOG > 5; return undef; } elsif (-l _) { $y->{y_type} = 'L'; $y->{y_linkto} = readlink($realpath); } elsif (-d _) { $y->{y_type} = 'D'; } elsif (-f _) { my $change = 0; $change++ if $y->{y_size} != $s[7]; $change++ if $y->{y_mtime} != $s[9]; $y->{y_type} = 'F'; $y->{y_size} = $s[7]; $y->{y_mtime} = $s[9]; # MD5 checksum is very expensive. # Do not calculate checksum in this version. # if ($change || $y->{y_checksum} !~ /^[a-f0-9]{32}$/) { # $y->fill_checksum; # } } else { # unkown types... return undef; } # fill out... $y->{y_perm} = $s[2] & 0777; $y->{y_owner} = $s[4]; $y->{y_group} = $s[5]; # get basename of the path $realpath =~ m%([^/]+)$%; $y->{y_name} = $1; $y->{y_realpath} = $realpath; # and result is hash ref. $y; } ;# ;# sub from_path ($$) { my $y = shift; my $realpath = shift; # $realpath must be exists... # my $flag = @_ ? shift : 0; $y->cleanup; # force to fill up $y->fill($realpath); } ;# ;# sub from_line ($$) { my $y = shift; my $str = shift; $y->cleanup; $y->{y_flag} = $1 if $str =~ s/^(-|\+|=)//o; $str =~ s/^(\S)\s*//o or carp("$y: can't detect file type"), return undef; $y->{y_type} = $1; my @x = split(/\s+/, $str); while (@x && $x[$[] =~ s/^(.)=//) { my($z, $val) = ($1, $'); shift(@x); if ($z eq 'p') { $y->{y_perm} = oct($val); } elsif ($z eq 'o') { ($y->{y_owner}, $y->{y_group}) = $val =~ /\./ ? ($`, $') : ($val, undef); } elsif ($z eq 'm') { $y->{y_mtime} = &get_mtime($val); } elsif ($z eq 's') { $y->{y_size} = $val; } elsif ($z eq 'c') { $y->{y_checksum} = $val; } elsif ($z eq 'l') { $y->{y_linkto} = attr_decode($val); } else { warn("$y: unknown attribute `$z', ignored.\n"); } } if (@x == 0) { ; # no filename is given } elsif (@x == 1) { $y->{y_name} = attr_decode(shift(@x)); } else { carp("$y: illegal line: $str"), return undef; } $y; } ;# ;# parsing a line from outputs of `ls', and return a reference ;# sub from_list ($$) { my $y = shift; local $_ = shift; local($[); # for zero based array # cleanup first. $y->cleanup; # make backup of input line. my $x = $_; # DOS dirstyle - DOS like timestamp if (/^\d\d-\d\d-\d\d\s+\d\d:\d\d(am|pm)?/i) { # DOS my $date = $&; $_ = $'; if (s/\s+\\s+//) { $y->{y_type} = 'D'; $y->{y_name} = $_; return $y; } if (s/\s+(\d+)\s+//) { $y->{y_type} = 'F'; $y->{y_size} = $1; $y->{y_date} = $date; $y->{y_time0} = &parsetime($date); $y->{y_name} = $_; return $y; } debug(6, "unknown DOS format: \"$x\"\n"), return undef; } # UNIX style - cut file modes first, thanks to Shigechika AIKAWA. s/^ ?(.)([-r][-w].[-r][-w].[-r][-w].)\s*// or debug(7, "invalid format: \"$x\"\n"), return undef; # save filetype and mode string. my $type = $1; my $tmp = $2; # convert mode string to octal value my $mode = 0; $mode |= 04000 if $tmp =~ /^..[sS]/; $mode |= 02000 if $tmp =~ /^.....[sS]/; $mode |= 01000 if $tmp =~ /^........[tT]/; $mode |= 00400 if $tmp =~ /^r/; $mode |= 00200 if $tmp =~ /^.w/; $mode |= 00100 if $tmp =~ /^..[xs]/; $mode |= 00040 if $tmp =~ /^...r/; $mode |= 00020 if $tmp =~ /^....w/; $mode |= 00010 if $tmp =~ /^.....[xs]/; $mode |= 00004 if $tmp =~ /^......r/; $mode |= 00002 if $tmp =~ /^.......w/; $mode |= 00001 if $tmp =~ /^........[xs]/; $mode &= 0777; # for security reason, mask is required. # find date string, and save some values # $regexp_month = 'Jun|Feb|...|Dec' # $regexp_t = '(\d+:\d+:\d+\s+\d\d\d\d)|(\d\d\d\d)|(\d+:\d+)'; /($regexp_month)\s+(\d?\d)\s+($regexp_t)/i or debug(7, "date not found: \"$x\"\n"), return undef; my($zz, $date, $file) = ($`, $&, $'); # get size $zz =~ s/\s*(\d+)\s*$// or debug(7, "size not found: \"$x\"\n"), return undef; my $size = $1; # get link count $zz =~ s/^(\d+)\s*// or debug(7, "nlink not found: \"$x\"\n"), return undef; my $nlink = $1; # and get owner (and group) my($uid, $gid) = $zz =~ /\s+/ ? ($`, $') : ($zz, undef); # set filename to $_ $_ = $file; # kill leading/trailing spaces, and trailing slash s/^\s+//; s/\s+$//; s/\/$//; # logging if ($LOG > 7) { debug(8, "parsing [$x]\n"); debug(8, " ... filename = $_\n"); debug(8, " ... type = $type\n"); debug(8, " ... mode = ".sprintf("%04o", $mode)."\n"); debug(8, " ... owner = $uid\n"); debug(8, " ... group = $gid\n") if defined($gid); debug(8, " ... size = $size\n"); debug(8, " ... date = $date\n"); my @a = reverse((gmtime(&parsetime($date)))[0..5]); $a[0] += 1900; $a[1]++; debug(8, " ... time = ". sprintf("%04d-%02d-%02d %02d:%02d:%02d\n", @a)); } # set common parameter $y->{y_perm} = $mode; $y->{y_owner} = $uid; $y->{y_group} = $gid if defined($gid); # check file types. if ($type eq 'd') { debug(8, "parse: directory $_\n"); $y->{y_type} = 'D'; } elsif ($type eq 'l') { my $linkto; ($_, $linkto) =/\s+->\s+/ ? ($`, $') : ($_, ''); debug(8, "parse: symlink $_ -> $linkto\n"); $y->{y_type} = 'L'; $y->{y_linkto} = $linkto; } elsif ($type eq '-') { debug(8, "parse: file $_\n"); $y->{y_type} = 'F'; $y->{y_size} = $size; $y->{y_date} = $date; $y->{y_time0} = &parsetime($date); } else { debug(7, "parse: unknown filetype [$type] for $_\n"); return undef; } # ignore files who have invalid name if ($_ eq '' || $_ eq '.' || $_ eq '..') { warn("$_: invalid file name.\n") if $LOG > 6; return undef; } # store filename $y->{y_name} = $_; # return this attribute object. $y; } ;# parse date strings and convert to time_t sub parsetime ($) { local $_ = shift; my($sec, $min, $hour, $day, $mon, $year) = /^($regexp_month)\s+(\d+)\s+((\d\d\d\d)|((\d+):(\d+)))$/oi ? (0, $7, $6, $2, $1, $4) : # Unix ls /^($regexp_month)\s+(\d+)\s+(\d+):(\d+):(\d+)\s+(\d\d\d\d)$/oi ? ($5, $4, $3, $2, $1, $6) : # Unix ls -T /^(\d+)\s+($regexp_month)\s+((\d\d\d\d)|((\d+):(\d+)))$/oi ? (0, $7, $6, $1, $2, $4) : # dls and NetWare /(\d+)-(\d+)-(\d+)\s+(\d+):(\d+)(AM|PM)?/oi ? (0, $5, ($6 eq 'PM' ? $4 + 12 : $4) , $2, $1, $3) : /(\d+)-(\S+)-(\d+)\s+(\d+):(\d+)/oi ? (0, $5, $4, $1, $2, $3) : # VMS style /^\w+\s+($regexp_month)\s+(\d+)\s+(\d+):(\d+):(\d+)\s+(\d+)/oi ? ($5, $4, $3, $2, $1, $6) : # CTAN style (and HTTP) /^\w+,\s+(\d+)-($regexp_month)-(\d+)\s+(\d+):(\d+):(\d+)/oi ? ($6, $5, $4, $1, $2, $3) : # another HTTP (); # undef... # convert month to index. my $month = ($mon =~ /^\d+$/ ? $& - 1 : $nametomonth{lc $mon}); # if year is not defined, use THIS year. if (!defined($year) || $year !~ /\d\d\d\d/) { my($l_month, $l_year) = (gmtime)[4, 5]; $year = $l_year; $year-- if $month > $l_month; } elsif ($year < 1970) { # if timestamp is too old, something wrong will happen. return 0 if $year < 1970; } # is this system dependant? $year -= 1900 if $year >= 1970; # check illegal sec/min/hour values. $sec = 0 unless defined($sec) && $sec >= 0 && $sec < 60; $min = 0 unless defined($min) && $min >= 0 && $min < 60; $hour = 0 unless defined($hour) && $hour >= 0 && $hour < 24; # return time value in GMT. return mktime($sec, $min, $hour, $day, $month, $year) + $tzoff; } ;# end of Fan::Attrib module ftpmirror-1.96/Fan/Attrib/Changes100644 1751 1750 174 6401315255 15135 0ustar ikuouserRevision history for Perl extension Fan::Attrib. 0.01 Thu Aug 21 21:20:14 1997 - original version; created by h2xs 1.18 ftpmirror-1.96/Fan/Attrib/MANIFEST100644 1751 1750 57 6401315255 14753 0ustar ikuouserAttrib.pm Changes MANIFEST Makefile.PL test.pl ftpmirror-1.96/Fan/Attrib/Makefile.PL100644 1751 1750 146 6401315256 15614 0ustar ikuouseruse ExtUtils::MakeMaker; WriteMakefile( 'NAME' => 'Fan::Attrib', 'VERSION_FROM' => 'Attrib.pm', ); ftpmirror-1.96/Fan/Attrib/test.pl100644 1751 1750 3260 6401315256 15176 0ustar ikuouseruse strict; use vars qw($loaded @nitems $list $path); use Getopt::Std; use Fan::Attrib; use Fan::Usage; BEGIN { $| = 1; print("1..1\n"); } END { print("not ok 1\n") unless $loaded; } $loaded = 1; print("ok 1\n"); # $Fan::Attrib::LOG = 6; # Fan::Attrib->new(attr_path => '/not/found/in/system'); # exit; # # @nitems = (100, 1000, 10000, 100000); @nitems = (50000); $list = '-r-xr-xr-x 1 root bin 7925 Aug 28 15:58 ftpmirror'; $path = '/usr/local/bin/ftpmirror'; # &alloc(1) or print("not ok 2\n"), exit(1); print("ok 2\n"); &alloc(0) or print("not ok 3\n"), exit(1); print("ok 3\n"); # to numeric for my $n (@nitems) { for my $l (1, 0) { &run($n, $l); } } # success terminate exit; # show system resource usage sub get_maxrss { my $u = getrusage; $u->ru_maxrss; } # try once for each type. sub alloc ($) { my $use_list = shift; my $a; if ($use_list) { ref($a = Fan::Attrib->new(attr_list => $list)) or warn("Can't create Attrib object"), return undef; } else { ref($a = Fan::Attrib->new(attr_path => $path)) or warn("Can't create Attrib object"), return undef; } 1; } # main processing... sub run { my $num = shift; my $use_list = shift; # my $rss = &get_maxrss; print "* before (n=$num, L=$use_list): maxrss=$rss\n"; # main loop... for (my $i = 0; $i < $num; $i++) { &alloc($use_list) or die("Can't allocate"); } # after care $rss = &get_maxrss; print "* result (n=$num, L=$use_list): maxrss=$rss\n"; # check result. if ($rss > 4000) { print "* Too large memory used..., "; # print "dump vars...\n"; # require "dumpvar.pl"; # dumpvar('Fan::Attrib'); # print "* and, "; print "kill myself.\n"; kill 6, $$; sleep(10); } # success... 1; } ftpmirror-1.96/Fan/Changes100644 1751 1750 175 6401315246 13711 0ustar ikuouserRevision history for Perl extension Fan::Archive. 0.01 Sat Aug 23 13:10:23 1997 - original version; created by h2xs 1.18 ftpmirror-1.96/Fan/Fan.pm100644 1751 1750 163620 7015726073 13553 0ustar ikuouser;# ;# 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 = ; 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 ftpmirror-1.96/Fan/MANIFEST100644 1751 1750 54 6401315247 13524 0ustar ikuouserChanges Fan.pm MANIFEST Makefile.PL test.pl ftpmirror-1.96/Fan/Makefile.PL100644 1751 1750 447 6600625752 14401 0ustar ikuouser;# $] >= 5.004 || die <<"EOT"; The version of your perl seems to be $]. To install `ftpmirror', perl version 5.004 or later is required. Check your path or install the newest perl, and try again. EOT ;# use ExtUtils::MakeMaker; ;# WriteMakefile( NAME => 'Fan', VERSION_FROM => 'Fan.pm', ); ftpmirror-1.96/Fan/test.pl100644 1751 1750 5524 6404275307 13763 0ustar ikuouseruse strict; use vars qw($VERSION $LOG %what_todo %need_network $todo $sysconfdir $loader %initval %pnest); ;# modules use Fan::Loader; use Fan::Cool; use Fan; ;# BEGIN { ;# For non-blocking stdout. $| = 1; $LOG = 5; # Data and time string. my $t = time; my $s = str4date($t).' '.str4time($t); # Show start up message. warn("$s FTPMIRROR starting...\n") if $LOG > 5; } ;# END { # Data and time string. my $t = time; my $s = str4date($t).' '.str4time($t); ;# Show terminate message. warn("$s FTPMIRROR terminated\n") if $LOG > 5; } ;# initialization... { use Config; # system configuration files $sysconfdir = $Config{prefix}.'/etc'; } $what_todo{'full-mirror'} = 'run_full_mirror'; $what_todo{'step-mirror'} = 'run_step_mirror'; $what_todo{'scan-local'} = 'scan_local'; $what_todo{'scan-remote'} = 'scan_remote'; $what_todo{'mkdirinfo'} = 'mkdirinfo'; $what_todo{'synch-remote'} = 'step_synch'; $what_todo{'update-master'} = 'update_master'; $need_network{'full-mirror'} = 1; $need_network{'step-mirror'} = 1; $need_network{'scan-remote'} = 1; $need_network{'synch-remote'} = 1; ;# check what shall we do ($todo) = $0 =~ m|([^/]+)$|; ;# if (@ARGV > 0 && $ARGV[$[] =~ /^--(\S+)$/ && defined($what_todo{$1})) { $todo = $1; shift; } ;# if (!defined($what_todo{$todo})) { $todo = 'full-mirror'; } ;# %initval = ( 'sysconfdir' => $sysconfdir, 'load-config' => "ftpmirror.cf", 'create-directories' => 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' => '~', ); ;# %pnest = ( 'archive' => 'PACKAGE::$_', 'package' => 'PACKAGE::$_', 'server' => 'SERVER::$_', ); ;# $loader = Fan::Loader->new( loader_keys => \%Fan::pkeys, loader_nest => \%pnest, ); ref($loader) && $loader->isa('Fan::Loader') or die("Can't create loader"); ;# Initial default parameters. $loader->merge_hash(\%initval, 'INIT') or die("Loader: Can't initialize values"); ;# Parsing options. $loader->parse_option($_, \@ARGV, 'OPTION') or die("Loader: Can't parse option: $_\n"); ;# Set logging level first. if (defined($_ = $loader->get_value('log-mask', 'INIT', 'OPTION'))) { plog_mask($_); } ;# Get 'load-config' parameter if (defined($_ = $loader->get_value('load-config', 'INIT', 'OPTION'))) { # get 'load-config' parameter my $dir = $loader->get_value('sysconfdir', 'INIT', 'OPTION'); # debug... warn("load files = $_\n") if $LOG > 6; # load configuration files for my $file (split(/\s+/)) { next if $file eq ''; $file = "$dir/$file" if ! -f $file && $dir ne ''; warn("loading $file...\n") if $LOG > 5; $loader->parse_file($file, 'DEFAULT') or die ("Loader Can't parse $file.\n"); } } # $loader->dumpall; exit; ftpmirror-1.96/Fan/Cool/ 40755 1751 1750 0 7031563566 13244 5ustar ikuouserftpmirror-1.96/Fan/Cool/Changes100644 1751 1750 172 6401315257 14604 0ustar ikuouserRevision history for Perl extension Fan::Cool. 0.01 Thu Aug 21 21:20:14 1997 - original version; created by h2xs 1.18 ftpmirror-1.96/Fan/Cool/Cool.pm100644 1751 1750 23510 7006023063 14575 0ustar ikuouser;# ;# Copyright (c) 1995-1997 ;# 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: Cool.pm,v 1.12 1999/10/28 10:32:19 ikuo Exp $ ;# package Fan::Cool; use strict; use vars qw($VERSION @ISA @EXPORT $LOG %plog_level @nameofday @nameofmonth @daysofmonth @accept %escape $black_hole_begin $black_hole_end); use Carp; use POSIX qw(errno_h); use AutoLoader 'AUTOLOAD'; require Exporter; @ISA = qw(Exporter); @EXPORT = qw( append mkdirhier rmdirhier plock encode decode plog plog_level plog_mask str4time str4date timezone isleap dayofweek daysofmonth nameofmonth lookup ); $VERSION = '0.01'; $LOG = 5; # default is INFO @plog_level{qw(EMERGE ALERT CRIT ERR WARNING NOTICE INFO DEBUG)} = (0..7); @nameofday = qw(Sun Mon Tue Wed Thu Fri Sat); @nameofmonth = qw(Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec); @daysofmonth = qw(31 28 31 30 31 30 31 31 30 31 30 31); ;# for encoding charactors @accept = ('*', '-', '.', '0'..'9', '@', 'A'..'Z', '_', 'a'..'z'); @escape{@accept} = @accept; ;# initialize @escape for (my $i = 0; $i < 256; $i++) { my $c = pack("C", $i); defined($escape{$c}) || ($escape{$c} = sprintf("%%%02x", $i)); $escape{' '} = '+'; } ;# for day counter $black_hole_begin = &days(3, 9, 1752); $black_hole_end = &days(14, 9, 1752); ;# prototypes are generated automatically by AutoSplit. ;# sub append (@); ;# sub mkdirhier ($$); ;# sub rmdirhier ($); ;# sub plog ($@); ;# sub plog_level ($); ;# sub plog_mask ($;$); ;# sub plock ($;$); ;# sub encode ; ;# sub decode ; ;# sub str4time (;$); ;# sub str4date (;$); ;# sub timezone (); ;# sub isleap (;$); ;# sub dayofyear ($$$); ;# sub days ($$$); ;# sub dayofweek ($$$); ;# sub daysofmonth ($;$); ;# sub nameofmonth ($); ;# sub lookup ($); ;# A special marker for AutoSplit. 1; __END__ ;# append(filename, string, string, ...); ;# Append some data to specified file. This routine ;# uses `plock' to lock output file. ;# sub append (@) { local *FILE; my $file = shift; my $result = $file ne '' && ! -d $file && @_ && plock("$file.LOCK") && open(FILE, ">>$file") && seek(FILE, 0, 2) && grep((print FILE), @_) && close(FILE) ? 1 : undef; unlink("$file.LOCK"); $result; } ;# ;# make directory hierachy sub mkdirhier ($$) { my $dir = shift; my $mode = shift; my $d = $dir =~ s%^/+%% ? '' : '.'; my $e; for $e (split('/', $dir)) { -d ($d .= '/'.$e) && next; unlink($d); # ignore result mkdir($d, $mode) || return undef; } 1; } ;# remove directory recursively sub rmdirhier ($) { my $dir = shift; # force to remove even if target is not a directory. return unlink($dir) if -l $dir || ! -d _; # try to open the target directory, and... local *DIR; opendir(DIR, $dir) || return undef; # search directory entires in this directory. my $e; while (defined($e = readdir(DIR))) { # rmdirhier can remove non-directory file. rmdirhier("$dir/$e") if $e ne '.' && $e ne '..'; } closedir(DIR); rmdir($dir); # the result value is that of rmdir. } ;# ;# Usage: plog(level, string, string, ...); ;# ;# sub plog ($@) { # determin logging level... my $level = shift; if ($level !~ /^\d+$/) { $level = &plog_level($level); } # calculate log mask. my $mask; { # We can't use ${$string} in `use strict'. no strict 'refs'; $mask = ${(caller)[$[].'::LOG'} || $LOG; } # only if specified log level is less or equal to mask. if ($level <= $mask) { local $_; # used in grep grep((print STDERR $_), @_); } # always success 1; } ;# Convert log name to level ;# For example, plog_level('INFO') returns 6. ;# sub plog_level ($) { my $lv = uc(shift); $lv =~ /^\d+$/ ? $lv : exists($plog_level{$lv}) ? $plog_level{$lv} : $LOG; } ;# Setting up log masks for generic modules. ;# For example, plog_mask("FTP=7,TCP,Scan", 6) causes ;# $FTP::LOG = 7; ;# $TCP::LOG = 6; ;# $Scan::LOG = 6; ;# sub plog_mask ($;$) { my @packages = split(/[,\s]+/, shift); my $lv = @_ ? plog_level(shift): $LOG; # default is $LOG. for my $str (@packages) { my($pack, $level) = $str =~ /=/ ? ($`, plog_level($')) : ($str, $lv); if ($pack ne '') { no strict 'refs'; ${$pack."::LOG"} = $level; } } } ;# ;# Usage: plock($filename, $timeout) ;# ;# An implementation of a lock mechanizem. `plock' uses `link' ;# function to lock a file, but uses no flock/lockf functions. ;# Second argument $timeout means how long seconds you may wait ;# until get lock. The default value of $timeout is 10[sec]. ;# sub plock ($;$) { my $file = shift; my $tt = @_ ? shift : 0; my $res = 0; local *FILE; ;# generate temporary filename my $temp = $file; $temp =~ s,[^/]+$,.LOCK.$$, || return undef; ;# check timeout value $tt = 10 if $tt < 1; ;# make sure that temporary file does not exist for (; -e $temp && !unlink($temp) && $tt > 0; $tt--) { sleep(1); } ;# create temporary file with process id $tt > 0 && open(FILE, ">$temp") && (print FILE "$$\n") && close(FILE) or unlink($temp), return undef; ;# link it to target file for (; !($res = link($temp, $file)) && $tt > 0; $tt--) { my $pid; if (open(FILE, $file) && chomp($pid = ) && close(FILE) && $pid =~ /^\d+$/) { # Got pid! if (kill(0, $pid)) { # Success to kill sleep(1); # wait a second } elsif (ESRCH != $!) { last; # permission denied? or other errors } else { unlink($file); sleep(1); # no need to sleep? } } else { unlink($file); sleep(1); # no need to sleep? } } ;# unlink temporary file unlink($temp); ;# result - success if link succeeded return $res; } ;# sub encode ($) { $_ = shift; s/./$escape{$&}/g; $_; } ;# sub decode ($) { $_ = shift; s/\+/ /go; s/%(..)/pack("H*", $1)/eg; $_; } ;# ;# generate time string, like "12:34:56", for given UTC time. ;# If $time is omitted, `str4time' returns a time string for the ;# current time. ;# sub str4time (;$) { sprintf("%02d:%02d:%02d", reverse((localtime(shift || time))[0..2])); } ;# ;# Usage: &str4data($time); ;# ;# Generate date string, like "1993-03-14", for given UTC time. ;# If $time is omitted, `str4date' returns a data string for the ;# current time. ;# sub str4date (;$) { my($d, $m, $y) = (localtime(shift || time))[3..5]; sprintf("%04d-%02d-%02d", $y + 1900, $m + 1, $d); } ;# ;# Usage: &timezone ;# ;# Find local timezone like "+0900" or "GMT". ;# To calculate timezone, we use UTC clock of `946684800' ;# which means "2000-01-01 00:00:00". ;# sub timezone () { local($[); # for zero-based array my($sec, $min, $hour, $day, $mon, $year) = localtime(946684800); my $sign = '+'; my $offset = $hour * 60 + $min; if ($year == 99) { $sign = '-'; $offset = 24 * 60 - $offset; } $offset++ if $offset % 10; return 'GMT' if !$offset; return $sign.'2359' if $offset >= 24 * 60; $sign.sprintf("%02d%02d", $offset / 60, $offset % 60); } ;# ;# Usage: isleap($year); ;# where $year is optional. ;# sub isleap (;$) { my($y) = @_ ? shift : (localtime)[5] + 1900; $y <= 1752 ? !($y % 4) : !($y % 4) && ($y % 100) || !($y % 400); } ;# ;# sub dayofyear ($$$) { my($day, $month, $year) = @_; my $i; $day++ if $month > 2 && &isleap($year); for ($i = 1; $i < $month; $i++) { $day += $daysofmonth[$i - 1]; } $day; } ;# ;# sub days ($$$) { my($day, $month, $year) = @_; my $days = &dayofyear($day, $month, $year); my $y = $year - 1; my $leap_years = int($y / 4) - ($y > 1700 ? int($y / 100) - 17 : 0) + ($y > 1600 ? int(($y - 1600) / 400) : 0); $days += $y * 365 + $leap_years; } ;# sub dayofweek ($$$) { my $yday = &days(@_); $yday < $black_hole_begin ? ($yday + 5) % 7 : $yday > $black_hole_end ? ($yday + 1) % 7 : 6; } ;# sub daysofmonth ($;$) { my $m = shift; my $y = shift; my $d = defined($daysofmonth[$m]) ? $daysofmonth[$m] : undef; $d++ if $y =~ /^\d+$/ && &isleap($y) && $m == 1; $d; } ;# sub nameofmonth ($) { my $m = shift; defined($nameofmonth[$m]) ? $nameofmonth[$m] : undef; } ;# ;# lookup a pathname ;# convert: ;# 1. "abc//xyz" to "abc/xyz" ;# 2. "abc/./xyz" to "abc/xyz" ;# 3. "abc/foo/../xyz" to "abc/syz" ;# NOTES: ;# This routine may be very slow... :-< ;# Would anybody rewrite this code? ;# sub lookup ($) { local $_ = shift; # null string is assumed as the current directory. $_ = '.' if $_ eq ''; # most of simple case... return $_ if !/\//; # try to convert pathname. $_ .= '/'; # 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 # try main loop. my $tmp; do { # xyz/foo/../bar -> xyz/bar $tmp = $_; s|([^/]+)/\.\./|$1 eq '..' ? '../../' : ''|geo; } while ($tmp ne $_) ; # aftercare s|^/|| if !$absolute; s|/+$|| if $_ ne '/'; $_ = '.' if $_ eq ''; $_; } ;# end of Fan::Cool module ftpmirror-1.96/Fan/Cool/MANIFEST100644 1751 1750 55 6401315260 14414 0ustar ikuouserChanges Cool.pm MANIFEST Makefile.PL test.pl ftpmirror-1.96/Fan/Cool/Makefile.PL100644 1751 1750 142 6401315261 15253 0ustar ikuouseruse ExtUtils::MakeMaker; WriteMakefile( 'NAME' => 'Fan::Cool', 'VERSION_FROM' => 'Cool.pm', ); ftpmirror-1.96/Fan/Cool/test.pl100644 1751 1750 1253 6401315261 14641 0ustar ikuouserBEGIN { $| = 1; print("1..2\n"); } END { print("not ok 1\n") unless $loaded; } use Fan::Cool; use Fan::Usage; # $LOG = 7; $loaded = 1; print("ok 1\n"); # 100000 -> 260K # 200000 -> 464K # 400000 -> 836K $string = "nan-jara-hoi"; &put_string(1, $string); printf("* before maxrss = %d\n", &get_maxrss); &put_string(500000, $string); printf("* result maxrss = %d\n", &get_maxrss); sub put_string ($$) { my $n = shift; my $zz = shift; while ($n-- > 0) { plog(7, "hogehoge, hogehoge, is $zz\n"); # &dummy(7, "hogehoge, hogehoge, is $zz\n"); } } sub get_maxrss { my $u = getrusage; $u->ru_maxrss; } sub dummy { my $level = shift; if ($level > 0) { grep(1, @_); } } ftpmirror-1.96/Fan/DIR/ 40755 1751 1750 0 7031563567 12767 5ustar ikuouserftpmirror-1.96/Fan/DIR/Changes100644 1751 1750 171 6401315262 14321 0ustar ikuouserRevision history for Perl extension Fan::DIR. 0.01 Thu Aug 21 21:20:15 1997 - original version; created by h2xs 1.18 ftpmirror-1.96/Fan/DIR/DIR.pm100644 1751 1750 22743 6405344012 14052 0ustar ikuouser;# ;# Copyright (c) 1995-1997 ;# 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: DIR.pm,v 1.12 1997/09/09 22:04:58 ikuo Exp $ ;# package Fan::DIR; use strict; use vars qw($VERSION $LOG %required %typemap %typerev); use Fan::Attrib; use Fan::Cool; use AutoLoader 'AUTOLOAD'; $VERSION = '0.01'; $LOG = 5; ;# @typemap{qw(directory symlink file)} = qw(D L F); @typerev{qw(D L F)} = qw(directory symlink file); @required{qw(D L F)} = ( [ qw(mode owner group begin-update end-update) ], [ qw(mode owner group linkto) ], [ qw(mode owner group modified size md5checksum) ] ); ;# A special marker for AutoSplit. 1; __END__ ;# ;# create a DIR object. ;# $dir = DIR->new(directory => "/ftp/pub/utils"); ;# sub new ($%) { my $this = shift; my $class = ref($this) || $this; my %params = @_; my $self = \%params; bless $self, $class; carp("DIR CREATING $self") if $LOG > 5; $self->{dir_hash} = {}; # empty hash $self->{dir_array} = []; # empty array $self; } ;# sub DESTROY ($) { my $self = shift; my $name; for $name (keys %{$self->{entires}}) { delete($self->{dir_hash}->{$name}); # delete Attribs } carp("DIR DESTROYING $self") if $LOG > 5; } ;# sub get ($$) { my $self = shift; my $name = shift; exists($self->{dir_hash}->{$name}) && ref($self->{dir_hash}->{$name}) eq 'Fan::Attrib' ? $self->{dir_hash}->{$name} : undef; } ;# sub add ($$) { my $self = shift; my $y = shift; $self->{dir_hash}->{$y->name} = $y if ref($y) eq 'Fan::Attrib'; $y; } ;# sub delete ($$) { my $self = shift; my $name = shift; delete($self->{dir_hash}->{$name}); } ;# sub index ($) { my $self = shift; @{$self->{dir_array}}; } ;# ;# Load entries from a file, and fill %{$self->{dir_hash}}. ;# $dir = DIR->new(dir_path => $directory); ;# $dir->load; ;# ;# You can specify a filename rather than a directory name. ;# $dir->load("$temp/tmp_dirinfo"); ;# sub load ($$) { my $self = shift; my $dir = @_ ? shift : $self->{dir_path}; my $dirinfo = -d $dir ? "$dir/.dirinfo" : $dir; my %assoc = (); local(*FILE, $_); # get directory info if exists -f $dirinfo or warn("$dirinfo is not a plain file."), return undef; open(FILE, $dirinfo) or warn("open($dirinfo): $!"), return undef; # my $pp = undef; while () { s/^\s+//; s/\s+$//; next if /^$/ || /^#/; /\s*=\s*/ || next; my($key, $val) = ($`, $'); if (defined($typemap{$key})) { $pp = \%{$assoc{$val}}; $pp->{y_type} = $typemap{$key}; $pp->{y_name} = $val; } elsif ($key eq 'modified') { $pp->{y_mtime} = $val; } elsif ($key eq 'mode') { $pp->{y_perm} = oct($val); } elsif ($key eq 'owner') { my $u = getpwnam($val) if $val !~ /^\d+$/; $val = $u if $u ne ''; $pp->{y_owner} = $val; } elsif ($key eq 'group') { my $g = getgrnam($val) if $val !~ /^\d+$/; $val = $g if $g ne ''; $pp->{y_group} = $val; } elsif ($key eq 'md5checksum') { $pp->{y_checksum} = $val if $val =~ /^[a-f0-9]{32}$/; } else { # others... $key =~ tr/-/_/; $pp->{"y_$key"} = $val; } } close(FILE); # DO NOT clear hash, but clean array # $self->{dir_hash} = {}; $self->{dir_array} = []; # register all entires.. my $name; for $name (sort keys %assoc) { next if $name eq '' || $name eq '.' || $name eq '..'; next if $name /\//; my $y = Fan::Attrib->new(%{$assoc{$name}}); if (defined($y) && ref($y) eq 'Fan::Attrib') { $self->add($y); # warn("load: $name... added\n") if $LOG > 7; push(@{$self->{dir_array}}, $name); } else { warn("Can't create Fan::Attrib object."); } } # success value 1; } ;# ;# fill directory information to $self->{dir_hash}. ;# make_dirinfo sets values of begin-update / end-update for directories ;# if and only if old dirinfo contains them. ;# Other values are re-generated by make_dirinfo. ;# sub fill ($$) { my $self = shift; my $dir = shift; # Calculating MD5 checksum is very slow... # We can choose calculate it or not. my $no_md5 = $self->{ignore_md5checksum}; local(*DIR, $[, $_); # check directory $dir ne '' && -d $dir or warn("dir is not a directory"), return undef; # get directory entries opendir(DIR, $dir) or carp("opendir($dir): $!"), return undef; my @list = sort readdir(DIR); closedir(DIR); # DO NOT clear my entries... # $self->{dir_hash} = {}; $self->{dir_array} = []; # checking all entries my $file; for $file (@list) { next if $file eq '' || $file eq '.' || $file eq '..'; next if $file =~ /^\.dirinfo/; next if $file =~ /\//; my $z = $self->get($file); my $y = Fan::Attrib->new(attr_path => "$dir/$file"); unless (defined($y) && ref($y) eq 'Fan::Attrib') { warn("Can't create attrib object."), next; } $y->fill_checksum; if ($z) { $z->copyfrom($y); # in overwrite mode. } else { $self->add($y); } # warn("fill: $file... added\n") if $LOG > 7; push(@{$self->{dir_array}}, $file); # register file name } # end of for $file (@list) { ... } # 1; } ;# Write directory information(in %{$self->{dir_hash}}) ;# to the file. ;# $dir = DIR->new($directory); ;# $dir->fill; ;# $dir->store; ;# ;# This routine will return zero if nothing has been modified, ;# or non-zero value will be returned. sub store ($;$) { my $self = shift; my $dir = @_ ? shift : $self->{dir_path}; my $dirinfo = -d $dir ? "$dir/.dirinfo" : $dir; my $temp = "$dirinfo.$$"; local(*FILE, *TEMP, $_); # next, we open the file with write mode open(TEMP, ">$temp") or carp("open($temp): $!"), return undef; # current directory information my $y; if (defined($y = $self->get('.'))) { &putdata($y, \*TEMP); } # my $name; for $name (@{$self->{dir_array}}) { $y = $self->get($name); # check filename # we hate illegal filenames, but '.' is a special filename # which contains current directory information. # shall we store information for '.' first? next if $name eq '' || $name eq '.' || $name eq '..'; next if $name =~ /^\.dirinfo/; next if $name =~ /\//; # warn("store: ".$y->name."...\n") if $LOG > 7; &putdata($y, \*TEMP); } # close temporary info file once. close(TEMP); # comapre old and new files. if (open(FILE, $dirinfo) && open(TEMP, $temp)) { my $comp = 0; my $cont = 1; while ($cont) { $cont = 0; my $x = ; my $y = ; if (defined($x) && defined($y)) { $x =~ s/\s+$//; $y =~ s/\s+$//; $cont++ if !($comp = $x cmp $y); } else { $comp = defined($x) || defined($y); } } close(FILE); close(TEMP); if (!$comp) { warn("$dir: no change\n") if $LOG > 6; unlink($temp), return 0; ## NO CHANGE } } # Now, we try to rename from temporary file to the real one. if (!rename($temp, $dirinfo)) { unlink($temp); warn("rename($temp, $dirinfo): $!\n") if $LOG > 4; return undef; } # We have changed! warn("store: $dir was updated") if $LOG > 6; return 1; # CHANGED } ;# ;# update dirinfo recursively ;# update_dirinfo returns 1 iff any change was found. ;# sub update { my $self = shift; my $dir = @_ ? shift : $self->{dir_path}; local(*DIR, $[, $_); my($old, $new, @stat, @list); my $dirinfo = "$dir/.dirinfo"; # check directory $dir ne '' && -d $dir or warn("dir is not a directory"), return undef; # generate entires. $self->load($dir); # load old values... $self->fill($dir); # and merge new values. # entries... my $file; for $file (@{$self->{dir_array}}) { next if $file eq '' || $file eq '.' || $file eq '..'; next if $file =~ /^\.dirinfo/; next if $file =~ /\//; # must not contain '/' my $y = $self->get($file); next if $y->type ne 'D'; my $t = time; # current time. my $kid = $self->new; if ($kid->update("$dir/$file") || !defined($y->{y_begin_update}) || !defined($y->{y_end_update})) { $y->{y_begin_update} = $t; $y->{y_end_update} = time; } } # end of for $file (@list) { ... } # return value is that of store. $self->store($dir); } ;# sub putdata { my $y = shift; # is Fan::Attrib object. my $out = shift; # must be a file handle. printf $out "%s = %s\n", $typerev{$y->type}, $y->name; my $key; for $key (@{$required{$y->type}}) { my $tmp = $key; $tmp =~ tr/-/_/; $tmp = "checksum" if $key eq 'md5checksum'; $tmp = "y_$tmp"; if ($key eq 'mode') { printf $out " $key = %04o\n", $y->{y_perm}; } elsif ($key eq 'modified') { printf $out " $key = %d\n", $y->{y_mtime}; } else { printf $out " %s = %s\n", $key, $y->{$tmp}; } } } ;# end of Fan::DIR module ftpmirror-1.96/Fan/DIR/MANIFEST100644 1751 1750 54 6401315263 14140 0ustar ikuouserChanges DIR.pm MANIFEST Makefile.PL test.pl ftpmirror-1.96/Fan/DIR/Makefile.PL100644 1751 1750 140 6401315264 14776 0ustar ikuouseruse ExtUtils::MakeMaker; WriteMakefile( 'NAME' => 'Fan::DIR', 'VERSION_FROM' => 'DIR.pm', ); ftpmirror-1.96/Fan/DIR/test.pl100644 1751 1750 1215 6401315264 14364 0ustar ikuouser# Before `make install' is performed this script should be runnable with # `make test'. After `make install' it should work as `perl test.pl' ######################### We start with some black magic to print on failure. # Change 1..1 below to 1..last_test_to_print . # (It may become useful if the test is moved to ./t subdirectory.) BEGIN { $| = 1; print "1..1\n"; } END {print "not ok 1\n" unless $loaded;} use Fan::DIR; $loaded = 1; print "ok 1\n"; ######################### End of black magic. # Insert your test code below (better if it prints "ok 13" # (correspondingly "not ok 13") depending on the success of chunk 13 # of the test code): ftpmirror-1.96/Fan/FTP/ 40755 1751 1750 0 7031563570 12774 5ustar ikuouserftpmirror-1.96/Fan/FTP/Changes100644 1751 1750 171 6401315265 14337 0ustar ikuouserRevision history for Perl extension Fan::FTP. 0.01 Thu Aug 21 21:20:15 1997 - original version; created by h2xs 1.18 ftpmirror-1.96/Fan/FTP/FTP.pm100644 1751 1750 44672 7006023063 14103 0ustar ikuouser;# ;# Copyright (c) 1995-1997 ;# 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: FTP.pm,v 1.28 1999/10/28 10:32:19 ikuo Exp $ ;# ;# Description: ;# FTP.pm - FTP Class definitions ;# - Socket based operations. ;# - Passive mode transfer is supported. ;# - Multiple addresses for a single server are supported. ;# - Multiple sessions are supported. ;# ;# Usage: ;# $dir = "/pub/FreeBSD"; ;# chdir($dir); ;# $ftp = FTP->new( ;# ftp_user => "anonymous", ;# ftp_pass => "ikuo\@intec.co.jp", ;# ftp_gateway => "proxy.isl.intec.co.jp", ;# ftp_server => "localhost" ;# ); ;# $ftp->login || die("Can't login ftp server.\n"); ;# $ftp->cwd($dir) || die("Can't change directory to $dir.\n"); ;# scalar(@array = $ftp->stat(".")) || die("Can't get status.\n"); ;# for $i (@array) { ;# $ftp->get($i) or warn("Can't get $i\n"), last; ;# } ;# $ftp->quit || warn("QUIT failed.\n"); ;# ;# package Fan::FTP; use strict; use vars qw(@ISA $VERSION $LOG $ftp_port $hostname $sockaddr_in $n_session %stats); use Carp; use Socket; use Fan::TCP; use AutoLoader 'AUTOLOAD'; @ISA = qw(Fan::TCP); $VERSION = '0.03'; $LOG = 5 unless defined($LOG); $ftp_port = (getservbyname('ftp', 'tcp'))[2]; chomp($hostname = `hostname`); ;# A special marker for AutoSplit. 1; __END__ ;# Show statistics report. sub stats ($) { my $self = shift; my $name = $self->{ftp_server}; my $p; exists($stats{$name}) && ref($p = $stats{$name}) or return undef; my $cs = $p->{ctrl_sent} + 0; my $cr = $p->{ctrl_recv} + 0; my $ds = $p->{data_sent} + 0; my $dr = $p->{data_recv} + 0; 1 while $cs =~ s/(\d+)(\d\d\d)/$1,$2/; 1 while $cr =~ s/(\d+)(\d\d\d)/$1,$2/; 1 while $ds =~ s/(\d+)(\d\d\d)/$1,$2/; 1 while $dr =~ s/(\d+)(\d\d\d)/$1,$2/; my $len = 0; $len = length($cs) if $len < length($cs); $len = length($cr) if $len < length($cr); $len = length($ds) if $len < length($ds); $len = length($dr) if $len < length($dr); warn("$self status reports (server name: $name)\n"); warn(" sent(ctrl)". '.' x ($len + 3 - length($cs)) . " $cs octets\n"); warn(" recv(ctrl)". '.' x ($len + 3 - length($cr)) . " $cr octets\n"); warn(" sent(data)". '.' x ($len + 3 - length($ds)) . " $ds octets\n"); warn(" recv(data)". '.' x ($len + 3 - length($dr)) . " $dr octets\n"); 1; } ;# destroy an object. sub DESTROY ($) { my $self = shift; $self->quit; my $p = \%{$stats{$self->{ftp_server}}}; $p->{ctrl_sent} += $self->{tcp_sent_octets}; $p->{ctrl_recv} += $self->{tcp_recv_octets}; $self->stats if $self->{ftp_stats}; carp("FTP DESTROYING $self") if $LOG > 5; Fan::TCP::DESTROY($self); } ;# creat a new object. ;# bindaddress undef ;# server nont ;# port 21 ;# user anonymous ;# pass "$user\@$hostname" sub new ($%) { my $this = shift; my $class = ref($this) || $this; my %param = @_; # if we required verbose output, set tcp_debug. $param{tcp_debug} = 1 if $LOG > 5; # bless myself. my $self = bless Fan::TCP->new(%param), $class; ref($self) or return undef; # log message carp("FTP CREATING $self") if $LOG > 5; # some default values. $self->{ftp_retry} = 3 if !exists($self->{ftp_retry}); $self->{ftp_login_retry} = 0 if !exists($self->{ftp_login_retry}); $self->{ftp_login_delay} = 60 if !exists($self->{ftp_login_delay}); # result is myself. $self; } ;# sub passive ($;$) { my $self = shift; if (@_) { my $t = shift; if ($LOG > 6) { warn("FTP $self passive mode " .($t ? "enabled" : "disabled").".\n"); } $self->{ftp_passive} = $t; } $self->{ftp_passive}; } ;# send FTP request. sub putreq ($$) { my $self = shift; my $req = shift; my $i = $self->{ftp_retry}; $self->clearerror || return undef; $self->{lastcode} = 0; $self->{lastmesg} = ''; do { # if we have no connection, try login. unless ($self->handle || $self->login) { $self->{lastmesg} = "can't login to the server"; return undef; } # try send command. unless ($self->putln($req)) { $self->{lastmesg} = $self->error; return undef; } # check result, 421 means connection closed. unless ($self->getres == 421) { return $self->{lastcode}; # this is good! } # or 421 was returned. warn("FTP: server said code=421, try again.\n") if $LOG > 4; $self->quit; } while ($i-- > 0 && sleep(10)) ; warn("FTP: gave up \"$req\".\n") if $LOG > 4; $self->{lastmesg} = "putreq: too many retries"; undef; } ;# recieve FTP response. sub getres ($) { my $self = shift; my $buffer = ''; my $line; while (defined($line = $self->getln)) { $buffer .= "\n" if $buffer ne ''; $buffer .= $line; if ($line =~ /^(\d\d\d) /) { $self->{lastcode} = $1; ($self->{lastmesg} = $') =~ s/\s+$//; $self->{buffer} = $buffer; return $self->{lastcode}; } } $self->{lastcode} = 0; $self->{lastmesg} = "no response from server"; undef; # status may be changed in getln or end-of-file } ;# quit session. sub quit ($) { my $self = shift; $self->cleardataconn; if ($self->handle) { # has connection $self->putreq("QUIT") && $self->getres; # ignore result $self->close; } } ;# sub login ($) { my $self = shift; my $i = $self->{ftp_login_retry}; # log... warn("login: connecting to the server...\n") if $LOG > 4.5; # loop for retries... do { # try login if ($self->do_login) { # success to login warn("login: success.\n") if $LOG > 4.5; return 1; } # check result code if ($self->{lastcode} != 421) { $self->error($self->{lastmesg}); return undef; } } while ($i-- > 0 && sleep($self->{ftp_retry_delay})) ; # retry timed out warn("login: too many login failure, gave up.\n") if $LOG > 4.5; $self->error("too many login failure, ".$self->{lastmesg}); undef; } ;# connecting the server. sub do_login ($) { my $self = shift; # close existing connection first. $self->quit; # force to clear status. $self->clearerror(1); # clear some FTP flags delete($self->{no_size}); delete($self->{no_mdtm}); delete($self->{no_chmod}); delete($self->{no_umask}); delete($self->{no_idle}); # get values. my $user = $self->{ftp_user}; my $pass = $self->{ftp_pass}; my $server = $self->{ftp_server}; my $port = $self->{ftp_port} || $ftp_port; my $bindaddr = $self->{ftp_bindaddr}; my $group = $self->{ftp_group}; my $gpass = $self->{ftp_gpass}; my $passive = $self->{ftp_passive}; my $idle = $self->{ftp_idle}; my $dir = $self->{ftp_directory}; # check default values. if ($user eq '') { $user = 'anonymous'; } if ($pass eq '') { $pass = getpwuid($<).'@'.$hostname; } if ($server eq '') { carp("FTP server not defined"), return undef; } if ($self->{ftp_gateway} ne '') { $user .= '@'.$server; $server = $self->{ftp_gateway}; } # opening connection. $self->do_client( tcp_bindaddr => $bindaddr, tcp_host => $server, tcp_port => $port ) or carp("FTP opening connection failed"), return undef; # we want initial message if ($self->getres != 220) { carp("do_login: can't connect") if $LOG > 5; $self->quit; return undef; } # try to send USER command unless ($self->putln("USER $user")) { carp("do_login: putln ".$self->error) if $LOG > 5; $self->quit; return undef; } # check response for USER command if ($self->getres == 331) { unless ($self->putln("PASS $pass")) { carp("do_login: putln ".$self->error) if $LOG > 5; $self->quit; return undef; } $self->getres; # to catch response code. } # check response for USER or PASS command if ($self->{lastcode} != 230) { carp("do_login: PASS: ".$self->error); $self->quit; return undef; } # if we are required to setup group... unless ($group eq '' || $self->group($group, $gpass)) { carp("do_login: GROUP: ".$self->error); $self->quit; return undef; } # is passive mode prefered? if ($passive) { $self->passive(1); # no error should occur. } # shall we change idle timer? if ($idle > 0 || $idle == -1) { my($i, $maxi) = $self->idle; $i = $idle == -1 || $idle > $maxi ? $maxi : $idle; $self->idle($i); # ignore result. } # we can change initial directory. unless ($dir eq '' || $self->chdir($dir)) { carp("do_login CHDIR: ".$self->error); $self->quit; return undef; } # success code. 1; } ;# ;# open accept socket, and send PORT command to the server. ;# sub port ($) { my $self = shift; $self->clearerror || return undef; $self->cleardataconn; # always success my($port, $addr) = $self->sockname; my $acpt = Fan::TCP->new(); unless (defined($acpt)) { warn("Fan::TCP->new failed"); return undef; } unless ($acpt->do_server(tcp_bindaddr => $addr)) { warn("Fan::TCP->do_server failed"); return undef; } ($port, $addr) = $acpt->sockname; unless ($addr =~ tr/./,/ == 3) { warn("ADDRESS=$addr must have just 3 dots"); return undef; } $addr .= sprintf(",%d,%d", ($port >> 8) & 0xff, $port & 0xff); unless ($self->putreq("PORT $addr") =~ /^2/) { warn("PORT command failed\n") if $LOG > 5; $self->error($self->{lastmesg}); return undef; } $self->{ftp_acpt} = $acpt; # now, ready to accept 1; } ;# sub acpt ($) { my $self = shift; $self->clearerror || return undef; my $data = $self->{ftp_acpt}->new_client; delete($self->{ftp_acpt}); # this cause close. $self->{ftp_data} = $data; 1; } ;# ;# open passive socket ;# sub pasv ($) { my $self = shift; my $a_regexp = '\((\d+),(\d+),(\d+),(\d+),(\d+),(\d+)\)'; $self->clearerror && $self->cleardataconn || return undef; if ($self->putreq("PASV") !~ /^2/) { $self->error($self->{lastmesg}); return undef; } if ($self->{lastmesg} !~ $a_regexp) { $self->error("pasv: no ADDR,PORT pair found"); return undef; } my $bindaddr = $self->{ftp_bindaddr}; my $port = $5 * 256 + $6; my $addr = join('.', $1, $2, $3, $4); my $data = Fan::TCP->new(); $data && $data->do_client( tcp_bindaddr => $bindaddr, tcp_host => $addr, tcp_port => $port ) or $self->error("can't do_client"), return undef; $self->{ftp_data} = $data; 1; } ;# clear data connection. ;# accept socket will be also closed. sub cleardataconn ($) { my $self = shift; # count up if (ref($self->{ftp_data})) { my $x = $self->{ftp_data}; $x->close; my $p = \%{$stats{$self->{ftp_server}}}; $p->{data_sent} += $x->{tcp_sent_octets}; $p->{data_recv} += $x->{tcp_recv_octets}; } # clean up delete($self->{ftp_acpt}); delete($self->{ftp_data}); # always success 1; } ;# sub makedataconn ($$) { my $self = shift; my $command = shift; ($self->passive ? $self->pasv : $self->port) && $self->putreq($command) == 150 && ($self->passive || $self->acpt) ? $self->{ftp_data} : $self->status(0); } ;# sub list ($$) { my $self = shift; my $path = shift; # ASCII mode was required for listing directory. $self->ascii or return undef; my $data = $self->makedataconn("LIST $path"); ref($data) && $data->isa('Fan::TCP') or $self->status(0), return undef; my $line = $data->getln; my @list = $line =~ /^total\s/ ? () : ($line); while (defined($line = $data->getln)) { push(@list, $line); } undef $data; $self->cleardataconn; $self->getres =~ /^2/ or $self->status(0), return undef; join("\n", @list); } ;# sub get ($$;$) { my $self = shift; my ($rx, $lx) = @_; my ($temp, $length); $lx = $rx if $lx eq ''; ($temp = $lx) =~ s%[^/]+$%.in.$&%; local *FILE; unless (CORE::open(FILE, ">$temp")) { return $self->status(0); } my $data = $self->makedataconn("RETR $rx"); unless (ref($data) && $data->isa('Fan::TCP')) { CORE::close(FILE); unlink($temp); return $self->status(0); } local $_; while (defined($_ = $data->getdata(4096))) { (print FILE $_) || last; } undef $data; $self->cleardataconn; CORE::close(FILE); if ($self->getres !~ /^2/) { unlink($temp); return $self->status(0); } unless (CORE::rename($temp, $lx)) { my $e = $!.''; $self->error($e); return undef; } 1; } ;# sub put ($$;$) { my $self = shift; my ($lx, $rx) = @_; my $length; local ($_, *FILE); -f $lx && CORE::open(FILE, $lx) or return undef; $rx = $lx if $rx eq ''; my $data = $self->makedataconn("STOR $rx"); CORE::close(FILE), return $self->status(0) if ref($data) ne 'Fan::TCP'; while (($length = read(FILE, $_, 2048)) > 0) { $data->putdata($_) || last; } undef $data; $self->cleardataconn; CORE::close(FILE); if ($length || $self->getres !~ /^2/) { return $self->status(0); } 1; } ;# sub stat ($;$) { my $self = shift; my $command = "STAT"; $command .= ' '.shift if @_; if ($self->putreq($command) !~ /^2/) { $self->error($self->{lastmesg}); return undef; } local $_ = $self->{buffer}; s/\r//g; # ignore "\r". 1 while s/^\d\d\d-[^\n]*\n//; # skip prepended messages s/^total\s+\d+\n//; # ignore first "total ..." s/(^|\n)2\d\d ([^\n]*$)//; # skip result message # Some FTP servers or FTP gateways close connection by STAT # command. Check it now! my $tmp = $2; if ($tmp =~ /good\s?bye/i) { if ($LOG > 4) { warn("stat: server said \"$self->{lastmesg}\"\n"); warn("stat: connection might be closed.\n"); warn("stat: check your server.\n"); } $self->error("stat: connection might be closed"); return undef; } # or concatinated string will be returned. $_; } ;# CAUTION ;# CHDIR SHOULD SUPPORT "" IN DIRECTORY NAME ;# sub chdir ($$) { my $self = shift; my $dir = shift; if ($self->putreq("CWD $dir") !~ /^2/) { $self->error($self->{lastmesg}); return undef; } 1; } ;# sub cwd ($$) { my $self = shift; $self->chdir(shift); } ;# CAUTION ;# PWD SHOULD SUPPORT "" IN DIRECTORY NAME ;# sub pwd ($) { my $self = shift; if ($self->putreq("PWD") !~ /^2/) { $self->error($self->{lastmesg}); return undef; } if ($self->{lastmesg} !~ /^"(\S+)"/) { $self->error("pwd: no directory name found"); return undef; } $1; } ;# ;# sub type ($;$) { my $self = shift; if (@_) { my $type = shift; if ($self->putreq("TYPE $type") !~ /^2/) { $self->error("type: $self->{lastmesg}"); return undef; } $self->{ftp_type} = $type; } $self->{ftp_type}; } ;# sub image ($) { my $self = shift; $self->type eq 'I' || $self->type('I'); } ;# sub ascii ($) { my $self = shift; $self->type eq 'A' || $self->type('A'); } ;# sub size ($$) { my $self = shift; my $path = shift; if ($self->{no_size}) { $self->error("SIZE: not supported."); return undef; } if ($self->putreq("SIZE $path") !~ /^2/) { $self->{no_size}++ if $self->{lastcode} =~ /^5/; $self->error("size: $self->{lastmesg}"); return undef; } if ($self->{lastmesg} !~ /^\d+$/) { $self->error("size: no SIZE found"); return undef; } return $&; } ;# sub mtime ($$) { my $self = shift; my $path = shift; if ($self->{no_mdtm}){ $self->error("MDTM: not supported."); return undef; } if ($self->putreq("MDTM $path") !~ /^2/) { $self->{no_mdtm}++ if $self->{lastcode} =~ /^5/; $self->error("mdtm: $self->{lastmesg}"); return undef; } if ($self->{lastmesg} !~ /^\d+$/) { $self->error("mdtm: no MTIME found"); return undef; } return $&; } ;# sub unlink ($$) { my $self = shift; my $path = shift; if ($self->putreq("DELE $path") !~ /^2/) { $self->error("dele: $self->{lastmesg}"); return undef; } 1; } ;# sub mkdir ($$) { my $self = shift; my $path = shift; if ($self->putreq("MKD $path") !~ /^2/) { $self->error("MKD: $self->{lastmesg}"); return undef; } 1; } ;# sub rmdir ($$) { my $self = shift; my $path = shift; if ($self->putreq("RMD $path") !~ /^2/) { $self->error("RMD: $self->{lastmesg}"); return undef; } 1; } ;# sub rename ($$$) { my $self = shift; my $old = shift; my $new = shift; if ($self->putreq("RNFR $old") != 350) { $self->error("RNFR: $self->{lastmesg}"); return undef; } if ($self->putreq("RNTO $new") !~ /^2/) { $self->error("RNTO: $self->{lastmesg}"); return undef; } 1; } ;# sub chmod ($$$) { my $self = shift; my $mode = shift; # number, not a octal string my $file = shift; my $perm = sprintf("%o", $mode); if ($self->{no_chmod}) { $self->error("SITE CHMOD: not supported."); return undef; } if ($self->putreq("SITE CHMOD $perm $file") != 200) { $self->{no_chmod}++ if $self->{lastcode} =~ /^5/; $self->error("SITE CHMOD: $self->{lastmesg}"); return undef; } 1; } ;# sub umask ($$) { my $self = shift; my $umask = shift; if ($self->{no_umask}){ $self->error("SITE UMASK: not supported."); return undef; } if ($self->putreq("SITE UMASK $umask") !~ /^2/) { $self->{no_umask}++ if $self->{lastcode} =~ /^5/; $self->error("UMASK: $self->{lastmesg}"); return undef; } 1; } ;# sub group ($$$) { my $self = shift; my $group = shift; my $gpass = shift; if ($self->putreq("SITE GROUP $group") !~ /^2/) { $self->error("GROUP: $self->{lastmesg}"); return undef; } if ($self->putreq("SITE GPASS $gpass") !~ /^2/) { $self->error("GPASS: $self->{lastmesg}"); return undef; } 1; } ;# sub idle { my $self = shift; if ($self->{no_idle}) { $self->error("SITE IDLE: not supported."); return wantarray ? () : undef; } if (@_) { if ($self->putreq("SITE IDLE $_[$[]") !~ /^2/) { $self->{no_idle}++ if $self->{lastcode} =~ /^5/; $self->error("IDLE: $self->{lastmesg}"); return undef; } if ($self->{lastmesg} !~ /\d+/) { $self->error("IDLE: no IDLE timer found"); return undef; } return $&; } else { if ($self->putreq("SITE IDLE") !~ /^2/) { $self->{no_idle}++ if $self->{lastcode} =~ /^5/; $self->error("IDLE: $self->{lastmesg}"); return undef; } if ($self->{lastmesg} !~ /(\d+)\D+(\d+)/) { $self->error("IDLE: no IDLE,MAXIDLE timers found"); return undef; } return wantarray ? ($1, $2) : $1; } } ;# end of Fan::FTP module ftpmirror-1.96/Fan/FTP/MANIFEST100644 1751 1750 54 6401315266 14156 0ustar ikuouserChanges FTP.pm MANIFEST Makefile.PL test.pl ftpmirror-1.96/Fan/FTP/Makefile.PL100644 1751 1750 140 6401315267 15014 0ustar ikuouseruse ExtUtils::MakeMaker; WriteMakefile( 'NAME' => 'Fan::FTP', 'VERSION_FROM' => 'FTP.pm', ); ftpmirror-1.96/Fan/FTP/test.pl100644 1751 1750 2226 6401315267 14405 0ustar ikuouserBEGIN { $| = 1; print "1..6\n"; } END { print("not ok 1\n") unless $loaded; } sub prompt { my $prompt = shift; local $_; print STDERR $prompt; defined($_ = ) || return undef; chomp; $_; } use Fan::FTP; $loaded = 1; print("ok 1\n"); chomp($hostname = `hostname`); $username = getpwuid($<).'@'.$hostname; $server = &prompt("try to connect anon-FTP server.\nenter server name: ") or print("not ok 2\n"), exit(1); $ftp = Fan::FTP->new( ftp_server => $server, ftp_user => 'anonymous', ftp_pass => $username ); ref($ftp) && $ftp->isa('Fan::TCP') or print("not ok 2\n"), exit(1); print("ok 2\n"); $ftp->login or print("not ok 3\n"), exit(1); print("ok 3\n"); #$ftp->chdir("/tmp/temp") # or die("Can't change directory to /tmp/temp\n"); defined($_ = $ftp->stat('.')) or print("not ok 4\n"), exit(1); print("ok 4\n"); if (1) { print "length = ".length($_)."\n"; for my $i (split(/\n/)) { print "+ $i\n"; } } defined($_ = $ftp->list('.')) or print("not ok 5\n"), exit(1); print("ok 5\n"); if (1) { print "length = ".length($_)."\n"; for my $i (split(/\n/)) { print "+ $i\n"; } } $ftp->quit or print("not ok 6\n"), exit(1); print("ok 6\n"); ftpmirror-1.96/Fan/Farm/ 40755 1751 1750 0 7031563570 13230 5ustar ikuouserftpmirror-1.96/Fan/Farm/Changes100644 1751 1750 172 6402110661 14566 0ustar ikuouserRevision history for Perl extension Fan::Farm. 0.01 Fri Aug 22 19:05:43 1997 - original version; created by h2xs 1.18 ftpmirror-1.96/Fan/Farm/Farm.pm100644 1751 1750 61601 6412637240 14572 0ustar ikuouser;# ;# Copyright (c) 1995-1997 ;# 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: Farm.pm,v 1.21 1997/09/26 04:48:32 ikuo Exp $ ;# package Fan::Farm; use strict; use vars qw($VERSION $LOG); use Carp; use Fan::MD5; use Fan::Cool; use Fan::Scan; use AutoLoader 'AUTOLOAD'; $VERSION = '0.04'; $LOG = 5; ;# A special marker for AutoSplit. 1; __END__ ;# ;# Destroy FTP Archive Revision Manager object. ;# sub DESTROY ($) { my $p = shift; # myself. my $dir = $p->{work_directory}; # farm directory. # Unlink all temporary files, including the lock file # for the working directory. for my $file (keys %{$p->{tempfiles}}) { warn("Fan::Farm unlink $file...\n") if $LOG > 5; unlink($file) if -e $file; } # Log message. carp("Fan::Farm DESTROYING $p") if $LOG > 5; } ;# ;# Creating FTP Archive Revision Managemer object. ;# ;# Usage: THIS::CLASS->new(directory_name); ;# ;# where directory_name is the directory who contains index ;# or step files. ;# ;# Index files are named as: index.1, index.2, ... ;# And step files: step.1, step.2, ... ;# step.n contains all differences between index.n and ;# index.(n+1), that is, we can generate index.(n+1) if we ;# have index.n and step.n. ;# ;# There may be also local index file, named `index.local' ;# which contains index of this work directory itself. ;# sub new ($$) { my $this = shift; my $class = ref($this) || $this; my $dir = shift; # Check directory definition. if ($dir eq '') { carp("Fan::Farm directory not defined") if $LOG > 5; return undef; } # Check directory existence. if (! -d $dir) { carp("Fan::Farm no directory: $dir") if $LOG > 4; return undef; } # Try bless this object before we lock this directory. my $p = bless { work_directory => $dir }, $class; ref($p) || croak("Fan::Farm can't bless object"); carp("Fan::Farm CREATING $p") if $LOG > 5; # Add the lock file to the hash of temporary files. my $lock = "$dir/.LOCK"; $p->{tempfiles}->{$lock}++; # Try to lock directory. unless (plock($lock, 30)) { carp("Fan::Farm can't lock directory: $dir") if $LOG > 4; return undef; } # Try to get revision. unless ($p->getrev) { carp("Fan::Farm can't get revision") if $LOG > 4; return undef; } # Return myself. $p; } ;# ;# farm_begin ... ;# initialize farm index updater. ;# sub d_begin ($) { my $p = shift; my $dir = $p->{work_directory}; my $fh; # clear $p->{pim_stack} = []; $p->{pim_depth} = 0; $p->{pim_modified} = 0; # Check revisions... exists($p->{pim_index_new}) || $p->getrev or return undef; # check revision numbers my $rev = $p->{pim_index_new}; $p->{pim_index} = "$dir/index.$rev"; $p->{pim_index_tmp} = $p->{pim_index}.'.tmp'; local *TMPINDEX; unless (open(TMPINDEX, ">$p->{pim_index_tmp}")) { carp("d_begin open($p->{pim_index_tmp}): $!"); return undef; } $p->{pim_index_handle} = *TMPINDEX; # information log... warn("Farm::begin: open $p->{pim_index_tmp}: o.k.\n") if $LOG > 5; # CAUTION: # WE CAN GENERATE STEP FILE EVEN IF WE ARE CREATING A NEW # INDEX FILE, BUT WE SHOULD GENERATE STEP FILE FROM INDEX # FILES... return 1; # shall we go step mode? $rev > 1 || return 1; # we are required step mode. $rev--; $p->{pim_step} = "$dir/step.$rev"; $p->{pim_step_tmp} = $p->{pim_step}.'.tmp'; # local *TMPSTEP; unless (open(TMPSTEP, ">$p->{pim_step_tmp}")) { carp("Farm::begin: open($p->{pim_step_tmp}): $!"); return undef; } $p->{pim_step_handle} = *TMPSTEP; # information log... warn("Farm::begin: open $p->{pim_step_tmp}: o.k.\n") if $LOG > 5; # success 1; } ;# ;# farm_add ;# add a file (Attrib object) to updater ;# sub d_add ($$) { my $p = shift; my $fh_index = $p->{pim_index_handle}; my $fh_step = $p->{pim_step_handle}; # check file handle first. unless (defined($fh_index)) { carp("Farm::add: has no file handle"); return undef; } my $y = shift; # Attribute. my $t = $y->type; # Abbrev for type of $y. my $f = $y->flag; # Abbrev for flag of $y. # At first, check the depth of the current tree. if ($t eq 'D') { warn("Farm::add: down to \"".$y->name."\"\n") if $LOG > 6; $p->{pim_depth}++; } elsif ($t eq 'U') { warn("Farm::add: up to \"..\"\n") if $LOG > 6; $p->{pim_depth}--; } else { warn("Farm::add: checking ".$y->name." (type=$t)...\n") if $LOG > 6; } # Check type/flag for given attribute. if ($t eq '.') { return $p->d_end; # terminator will be printed. } # check if we have any modification. if ($f ne '') { $p->{pim_modified} = 1; } # step mode ? if (!defined($fh_step)) { ; # no step mode } elsif ($t eq 'D' && $y->name eq '.') { print $fh_step $y->to_line."\n"; } elsif ($f eq '') { if ($t eq 'D') { push(@{$p->{pim_stack}}, $y); } elsif ($t eq 'U') { if (@{$p->{pim_stack}}) { pop(@{$p->{pim_stack}}); } else { print $fh_step "U\n"; } } } else { while (@{$p->{pim_stack}}) { my $a = shift(@{$p->{pim_stack}}); print $fh_step $a->to_line."\n"; } print $fh_step $y->to_line."\n"; } # index mode if ($f ne '-') { # ignore removed files. $y->flag(''); # clear flag print $fh_index $y->to_line."\n"; $y->flag($f); # restore. } # success 1; } ;# ;# farm_end ;# terminate updater ;# sub d_end ($) { my $p = shift; my $fh_index = $p->{pim_index_handle}; my $fh_step = $p->{pim_step_handle}; # Check file handle unless (defined($fh_index)) { carp("Farm::end: no file handle defined") if $LOG > 5; return undef; } # Check depth of working tree. if ($p->{pim_depth} < 1) { carp("Farm::end: ouch! pim_depth is too small") if $LOG > 4; close($fh_index); # We must close output file. delete($p->{pim_index_handle}); unlink($p->{pim_index_tmp}); warn("Farm::end: $p->{pim_index_tmp} unlinked.\n") if $LOG > 5; if (defined($fh_step)) { close($fh_step); delete($p->{pim_step_handle}); unlink($p->{pim_step_tmp}); warn("Farm::end: $p->{pim_step_tmp} unlinked.\n") if $LOG > 5; } return undef; } # Greater depth means "terminated abnormally" if ($p->{pim_depth} > 1) { carp("Farm::end: pim_depth > 1, index abort") if $LOG > 3; close($fh_index); # We must close output file. delete($p->{pim_index_handle}); unlink($p->{pim_index_tmp}); $fh_index = ''; warn("Farm::end: $p->{pim_index_tmp} unlinked.\n") if $LOG > 5; if (defined($fh_step)) { warn("Farm::end: try to fix step files.....\n") if $LOG > 5; while ($p->{pim_depth} > 1) { if (@{$p->{pim_stack}}) { pop(@{$p->{pim_stack}}); } else { print $fh_step "U\n"; } $p->{pim_depth}--; } } } # put terminator, and close output file. if (defined($fh_index)) { print $fh_index ".\n"; close($fh_index); delete($p->{pim_index_handle}); warn("Farm::end: $p->{pim_index_tmp} was closed.\n") if $LOG > 5; # modified flag my $mod = 1; # check modification if needed. if ($p->{pim_index_max} > 0) { # exists last one my $rev = $p->{pim_index_max}; my $dir = $p->{work_directory}; my $old = "$dir/index.$rev"; my $new = $p->{pim_index_tmp}; my $out = "$dir/step.$rev"; my $tmp = "$out.tmp"; $mod = &Fan::Scan::scan_mkdiff($tmp, $old, $new); if (!defined($mod)) { warn("Farm::end: can't generate step file" . ", use this index.\n") if $LOG >5; warn("Farm::end: unlink $tmp\n") if $LOG > 5; $mod = 1; } elsif ($mod == 0) { # no modification... warn("Farm::end: no change, $tmp removed.\n") if $LOG > 5; unlink($tmp); } elsif (!rename($tmp, $out)) { carp("Farm::end: rename $tmp -> $out: $!"); unlink($tmp); } } # check index modification... if ($mod == 0) { unlink($p->{pim_index_tmp}); warn("Farm::end: no change" . ", $p->{pim_index_tmp} removed.\n") if $LOG > 5; } elsif (rename($p->{pim_index_tmp}, $p->{pim_index})) { warn("Farm::end: rename to $p->{pim_index}: o.k.\n") if $LOG > 5; } else { carp("Farm::end: rename($p->{pim_index}): $!"); } } # step mode, skipped in this version. if (0 && defined($fh_step)) { print $fh_step ".\n"; close($fh_step); delete($p->{pim_step_handle}); warn("Farm::end: $p->{pim_step_tmp} was closed.\n") if $LOG > 5; if ($p->{pim_modified} == 0) { unlink($p->{pim_step_tmp}); warn("Farm::end: no chage" . ", $p->{pim_step_tmp} removed.\n") if $LOG > 5; } elsif (rename($p->{pim_step_tmp}, $p->{pim_step})) { warn("Farm::end: rename to $p->{pim_step}: o.k.\n") if $LOG > 5; } else { carp("Farm::end: rename($p->{pim_step}): $!"); } } # success, but really? 1; } ;# Master mode: ;# Generate full index of the given directory. ;# (as the newest index). ;# ;# this routine should be called after `update' routine. ;# ;# Usage: ;# $p->generate(directory); ;# where `directory' is the target directory. ;# sub generate ($$) { my $p = shift; my $dir = $p->{work_directory}; my $target = shift; # Check revisions... exists($p->{pim_index_new}) || $p->getrev or return undef; # Get revision... my $rev = $p->{pim_index_new}; my $outp = "$dir/index.$rev"; my $temp = "$outp.tmp"; # open temorary output file. unless (&Fan::Scan::scan_mklist($temp, $target)) { carp("generate:Fan:: Scan::mklist failure"); return undef; } # try compare... $rev--; if (exists($p->{pim_index_max}) && $p->{pim_index_max} == $rev) { my $old = "$dir/index.$rev"; my $step = "$dir/step.$rev"; my $tmps = "$step.tmp"; my $mod = &Fan::Scan::scan_mkdiff($tmps, $old, $temp); if (!defined($mod)) { warn("generate: scan_mkdiff failure, skipped.\n"); } elsif ($mod == 0) { unlink($tmps); warn("generate: no change, $tmps removed.\n") if $LOG > 5; unlink($temp); warn("generate: no change, $temp removed.\n") if $LOG > 5; return 1; # this is success case. } else { if (rename($tmps, $step)) { warn("generate: rename $tmps -> $step: o.k.\n") if $LOG > 5; } else { carp("generate: rename $tmps -> $step: $!"); unlink($tmps); } } } # now, try to rename. unless (rename($temp, $outp)) { carp("generate: rename $temp -> $outp: $!"); unlink($temp); return undef; } # warn("generate: rename $temp -> $outp: o.k.\n") if $LOG > 5; # success 1; } ;# Master and slave mode: ;# Normalize index directory. ;# (a) generate all step files. ;# (b) index files are removed except the newest one. ;# (but, show warning messages only, in this version.) ;# (c) all step files remain. ;# sub normalize ($;$) { my $p = shift; my $clean = shift; my $dir = $p->{work_directory}; # Force to check revisions... $p->getrev or return undef; # Check existence of index files... if (!exists($p->{pim_index_max})) { # we have no index file. carp("normalize: have no index file") if $LOG > 4; return undef; } # Update index files and calculate revisions again, if needed. if (exists($p->{pim_step_max})) { if ($p->{pim_step_max} >= $p->{pim_index_max}) { $p->update && $p->getrev or return undef; } } # Next, check step files. my $max_i = $p->{pim_index_max}; # DOES exist my $rev = $p->{pim_index_min}; # DOES exist $rev = $p->{pim_step_max} + 1 if exists($p->{pim_step_max}); # loop. while ($rev < $max_i) { my $out = "$dir/step.$rev"; my $tmp = "$out.tmp"; my $old = "$dir/index.$rev"; $rev++; my $new = "$dir/index.$rev"; unless (defined(&Fan::Scan::scan_mkdiff($tmp, $old, $new))) { carp("normalize: can't make diff"); unlink($tmp); return undef; } unless (rename($tmp, $out)) { carp("normalize: rename $tmp -> $out: $!"); unlink($tmp); return undef; } warn("normalize: rename $tmp -> $out: o.k.\n") if $LOG > 5; } # unlink redundant files... for ($rev = $p->{pim_index_min}; $rev < $max_i; $rev++) { if ($clean) { unlink("$dir/index.$rev"); warn("normalize: unlink $dir/index.$rev\n") if $LOG > 5; } else { warn("normalize: we should unlink $dir/index.$rev\n") if $LOG > 5; } } # get revision numbers once more. unless ($p->getrev) { carp("normalize: can't update revision numbers"); return undef; } # shall we clean up? $clean || return 1; # abbrev for revision numbers. my $min_s = 0; my $min_i = 0; # Initialize... $min_s = $p->{pim_step_min} if exists($p->{pim_step_min}); $min_i = $p->{pim_index_min} if exists($p->{pim_index_min}); # Open working directory local *DIR; unless (opendir(DIR, $dir)) { carp("normalize: opendir($dir): $!") if $LOG > 4; return undef; } # Search invalid step/index files my $e; while (defined($e = readdir(DIR))) { if ($e =~ /^step\.(\d+)(\.Z|\.gz)?$/) { if (!$min_s || $1 < $min_s) { warn("normalize: unlink $dir/$e\n") if $LOG > 5; # unlink("$dir/$e"); } } elsif ($e =~ /^index\.(\d+)(\.Z|\.gz)?$/) { if (!$min_i || $1 < $min_i) { warn("normalize: unlink $dir/$e\n") if $LOG > 5; # unlink("$dir/$e"); } } else { ; # simply ignored... } } closedir(DIR); # success code. 1; } ;# Master and slave mode: ;# Generate the newest index file from step files. ;# ;# Usage: ;# $p->updage; ;# sub update ($) { my $p = shift; my $dir = $p->{work_directory}; # Check revisions... exists($p->{pim_index_new}) || $p->getrev or return undef; # Check existence of index files... if (!exists($p->{pim_index_max})) { # we have no index file. carp("update: can't find base index file.\n") if $LOG > 4; return undef; } # Next, check step files. if (!exists($p->{pim_step_max})) { # no step file. warn("update: no step file.\n") if $LOG > 5; return 1; # seems good. } # Check revision numbers. if ($p->{pim_step_max} < $p->{pim_index_max}) { warn("update: revision check o.k.\n") if $LOG > 5; return 1; # seems good. } # Now, we can generate the newest index file. my $min = $p->{pim_index_max}; # we have... my $max = $p->{pim_step_max}; # we have... my $new = $max + 1; # Open the index who has maximum number. my $orig = "$dir/index.$min"; my @diff = (); while ($min <= $max) { push(@diff, "$dir/step.$max"); $min++; } my $outp = "$dir/index.$new"; my $temp = "$outp.tmp"; # update by Fan::Scan::scan_update. unless (&Fan::Scan::scan_update($temp, $orig, @diff)) { warn("update: Fan::Scan::scan_update failure\n"); unlink($temp); # unlink temporary file return undef; } # now try to rename... unless (rename($temp, $outp)) { carp("update: rename($outp): $!") if $LOG > 4; unlink($temp); # unlink temporary file return undef; } # debug log warn("update: rename $temp -> $outp: o.k.\n") if $LOG > 5; # success 1; } ;# ;# a fileter who pickup only step / index files. ;# sub farm_filter { my $y = shift; # Fan::Attrib object. my $t = $y->type; # type abbrev if ($t eq 'F') { my $n = $y->name; if ($n !~ /^(step|index)\.\d+(\.Z|\.gz)?$/) { warn("farm_filter: $n was skipped.\n") if $LOG > 6; return undef; } } 1; } ;# Master mode: ;# Generate local index of the index directory. ;# ;# Usage: ;# $p->genindex; ;# sub genindex ($) { my $p = shift; my $dir = $p->{work_directory}; my $scan = Fan::Scan->new( scan_type => 'LOCAL', scan_dir => $dir ); unless (ref($scan)) { carp("genindex: can't create Scan object"); return undef; } unless ($scan->add_filter(\&farm_filter)) { carp("genindex: can't add filter"); return undef; } my $local_index = "$dir/index.local"; my $tmp_index = "$local_index.tmp"; local *TEMP; unless (open(TEMP, ">$tmp_index")) { carp("genindex: open($tmp_index): $!"); return undef; } warn("genindex: open $tmp_index: o.k.\n") if $LOG > 5; my $y; while (defined($y = $scan->get)) { $y->fill_checksum; print TEMP $y->to_line."\n"; } close(TEMP); unless(rename($tmp_index, $local_index)) { carp("genindex: rename($local_index): $!"); unlink($tmp_index); warn("genindex: rename failed, unlink $tmp_index...\n") if $LOG > 5; return undef; } warn("genindex: rename to $local_index: o.k.\n"); 1; } ;# Slave mode: ;# Synchronize index directory to the master. ;# ;# Usage: ;# $p->synch('/ftp/db/foo/index.local', $ftp); ;# where $ftp supports $ftp->get(remote-file, local-file), and ;# '/db/foo/index.local' is the local-index filename in localhost. ;# sub synch ($$$$) { my $p = shift; # myself my $net = shift; # must support $net->get(remote, local). my $pre = shift; # prefix of remote files. my $start = shift; # file name we will start from. my $dir = $p->{work_directory}; # check local file. unless (-f $start) { carp("synch: file $start not found"); return undef; } # warn("synch: local file $start: o.k.\n") if $LOG > 5; # scanner my $scan = Fan::Scan->new( scan_type => 'INDEX', scan_index => $start, ); unless (ref($scan)) { carp("synch: can't create index scanner"); return undef; } # add filter unless ($scan->add_filter(\&farm_filter)) { carp("synch: can't add filter(index)"); return undef; } # local side scanner... my $ours = Fan::Scan->new( scan_type => 'LOCAL', scan_dir => $p->{work_directory} ); unless (ref($ours)) { carp("synch: can't create local scanner"); return undef; } # add filter unless ($ours->add_filter(\&farm_filter)) { carp("synch: can't add filter(local)"); return undef; } # parsing... # this is very simple mirror - only check size and checksum. my $max_y = undef; my $max_i = 0; my $a; my $b; while (($a, $b) = $ours->getcmp($scan)) { my $z; my $t; my $flag = 0; if (!defined($a) && !defined($b)) { confess("synch: UNEXPECTED CASE"); } elsif (!defined($a)) { $z = $b; $t = $z->type; $flag++; #warn("synch: local does not have $t $z->{y_name}.\n"); } elsif (!defined($b)) { $z = $a; $t = $z->type; $flag--; #warn("synch: remote does not have $t $z->{y_name}.\n"); } else { $z = $b; $t = $z->type; if ($t eq '.') { ; } elsif ($a->type ne $t) { $flag++; #warn("synch: type mismatch $t $z->{y_name}.\n"); } elsif ($t eq 'D') { ; } elsif ($t eq 'U') { ; } elsif ($t eq 'L') { $flag++ if $a->linkto ne $b->linkto; #warn("synch: linkto mismatch $t $z->{y_name}.\n"); } elsif ($t ne 'F') { carp("synch: UNKNOWN TYPE $t"); return undef; } elsif (!$a->fill_checksum) { carp("synch: can't get checksum of " . $a->realpath); return undef; } elsif ($a->size != $b->size) { $flag++; #warn("synch: size mismatch $t $z->{y_name}.\n"); } elsif ($b->checksum eq '') { carp("synch: NO CHECKSUM for ".$b->path); return undef; } elsif ($a->checksum ne $b->checksum) { $flag++; #warn("synch: checksum mismatch $t $z->{y_name}.\n"); } else { ; } } # check end. if ($t eq '.') { last; # done } # abbrev for path name my $path = "$dir/".$z->path; # check index file before $flag check. if ($t eq 'F' && $z->name =~ /^index\.(\d+)/) { ($max_y, $max_i) = ($z, $1) if $max_i < $1; next; } # check flag. we only check modified files. $flag > 0 or next; # check types... if ($t eq 'D') { unlink($path) if -e $path; unless (mkdir($path, 0755)) { carp("synch: mkdir($path): $!"); return undef; } warn("synch: mkdir($path, 0755): o.k.\n") if $LOG > 5; } elsif ($t eq 'U') { ; } elsif ($t eq 'L') { unlink($path) if -e $path; symlink($z->linkto, $path); warn("synch: symlink($path): o.k.\n") if $LOG > 5; } elsif ($t eq 'F' && $z->name =~ /^step\./) { unless ($net->get($pre.'/'.$z->path, $path)) { carp("synch: GET($path): ".$net->error); next; # skip this... } chmod((defined($z->perm) ? $z->perm : 0644), $path); my $m = $z->mtime; if ($m > 0) { utime($m, $m, $path); } warn("synch: get $path: o.k.\n") if $LOG > 5; } else { ; # what? } } # calculate revision numbers... $p->getrev || return undef; # try update. unless ($p->update) { warn("synch: can't update $dir, try continue...\n") if $LOG > 4; # continue... } # calculate revision numbers once more $p->getrev || return undef; # check remote side index file. unless (ref($max_y)) { carp("synch: no index file in remote"); return undef; } # relative path name my $path = $max_y->path; # check index number... # same index? if ($max_i == $p->{pim_index_max}) { if ($max_y->name !~ /^index\.(\d+)$/) { if ($LOG > 4) { warn("synch: remote index is compressed.\n"); warn("synch: skip checksum check.\n"); } return 1; } # or checksum test. if (MD5File("$dir/$path") eq $max_y->checksum) { warn("synch: checksum($dir/$path) ok, very good!\n") if $LOG > 5; return 1; } else { # checksum error warn("synch: checksum error, unlink $dir/$path.\n") if $LOG > 5; unlink("$dir/$path"); } } elsif ($max_i < $p->{pim_index_max}) { if ($LOG > 5) { warn("synch: local index($p->{pim_index_max}) was " . "greater than remote($max_i)\n"); warn("synch: this may be good...\n"); } return 1; } # remaining case is ($max_i > $p->{pim_index_max}), # or checksum error if (exists($p->{pim_index_max}) && $max_i > $p->{pim_index_max}) { warn("synch: remtoe has greater index($max_i)" ." than local($p->{pim_index_max}).\n") if $LOG > 4; } if ($LOG > 4) { warn("synch: try to get $path...\n"); } unless ($net->get("$pre/$path", "$dir/$path")) { carp("synch: GET($path): failed"); return undef; } unless ($max_y->checksum eq MD5File("$dir/$path")) { warn("synch: CHECKSUM($path) mismatch, unlink it.\n"); unlink("$dir/$path"); return undef; } chmod(0644, "$dir/$path"); my $m = $max_y->mtime; if ($m > 0) { utime($m, $m, "$dir/$path"); } # success to small mirror, get revisions again. $p->getrev; } ;# Get revision number for this package. ;# A file "step.i" is a diff file between "index.i" and ;# "index.(i+1)", that is, we can generate "index.12" ;# from "index.11" and "step.11". ;# ;# If this routine returns success code (== 1), you can ;# always access to $p->{pim_index_new}; ;# sub getrev ($) { my $p = shift; my $dir = $p->{work_directory}; # Clear old revision numbers. delete($p->{pim_index_max}); delete($p->{pim_index_min}); delete($p->{pim_index_new}); delete($p->{pim_step_max}); delete($p->{pim_step_min}); # try to open directory... local *DIR; unless (opendir(DIR, $dir)) { carp("getrev: opendir($dir): $!") if $LOG > 4; return undef; } # local variables to search revisions. my %steps = (); my %indexes = (); my $e; # read directory entries, and search `index.n'. while (defined($e = readdir(DIR))) { if ($e =~ /^step\.(\d+)(\.Z|\.gz)?$/) { $steps{$1 + 0}++; } elsif ($e =~ /^index\.(\d+)(\.Z|\.gz)?$/) { $indexes{$1 + 0}++; } else { ; # simply ignored. } } closedir(DIR); # sort steps in reverse order... my @steps = sort { $b <=> $a } keys %steps; my @indexes = sort { $b <=> $a } keys %indexes; # Maximum / minimum index of step files. my $max_s = 0; my $min_s = 0; # Check the chain of step files. # Search largest continuous block. if (@steps) { $min_s = $max_s = shift(@steps); while (@steps) { $min_s - 1 == shift(@steps) || last; $min_s--; } } # Indexes for index files. my $max_i = 0; my $min_i = 0; # Check the chain of step files. # Search largest continuous block. if (@indexes) { $min_i = $max_i = shift(@indexes); while (@indexes) { $min_i - 1 == shift(@indexes) || last; $min_i--; } } # Validation if ($max_i == 0 && $max_s == 0) { # nothing found. $p->{pim_index_new} = 1; } elsif ($max_i < $min_s) { # unexpected case... $p->{pim_index_new} = $max_s + 2; # skip one. } elsif ($max_s == 0 || $min_i > $max_s + 1) { # step has no meaning $p->{pim_index_max} = $max_i; # we have... $p->{pim_index_min} = $min_i; # we have... $p->{pim_index_new} = $max_i + 1; # we will... } else { # seems good. $p->{pim_step_max} = $max_s; # we have... $p->{pim_step_min} = $min_s; # we have... $p->{pim_index_max} = $max_i; # we have... $p->{pim_index_min} = $min_i; # we have... if ($max_i > $max_s) { # $max_i is maximum. $p->{pim_index_new} = $max_i + 1; # we will... } else { # we can generate ($max_s + 1). $p->{pim_index_new} = $max_s + 2; # we will... } } # return success code. 1; } ;# end of Fan::Farm module ftpmirror-1.96/Fan/Farm/MANIFEST100644 1751 1750 55 6402110661 14404 0ustar ikuouserChanges Farm.pm MANIFEST Makefile.PL test.pl ftpmirror-1.96/Fan/Farm/Makefile.PL100644 1751 1750 142 6402110661 15242 0ustar ikuouseruse ExtUtils::MakeMaker; WriteMakefile( 'NAME' => 'Fan::Farm', 'VERSION_FROM' => 'Farm.pm', ); ftpmirror-1.96/Fan/Farm/test.pl100644 1751 1750 2352 6402110662 14632 0ustar ikuouserBEGIN { $| = 1; print("1..3\n"); $tmpdir = './t'; } END { print("not ok 1\n") unless $loaded; rmdirhier($tmpdir) if -d $tmpdir; } use Fan::Cool; use Fan::FTP; use Fan::Farm; $Fan::Farm::LOG = 7; $loaded = 1; print("ok 1\n"); ;# clear first. rmdirhier($tmpdir); ;# making working directory. mkdirhier($tmpdir, 0755) or print("not ok 2 (mkdirhier)\n"), exit(1); ref($farm = Fan::Farm->new($tmpdir)) or print("not ok 2\n"), exit(1); print("ok 2\n"); # generate index from current directory. $farm->generate('.') && -f "$tmpdir/index.1" or print("not ok 3\n"), exit(1); print("ok 3\n"); #open(FILE, "$tmpdir/index.1"); #print("opening $tmpdir/index.1... ok\n"); #print while ; #close(FILE); ;# skip test 4 print("ok 4\n"); ;# clear again. rmdirhier($tmpdir); ;# mkdirhier($tmpdir, 0755) or print("not ok 5 (mkdirhier)\n"), exit(1); ref($farm = Fan::Farm->new($tmpdir)) or print("not ok 5\n"), exit(1); print("ok 5\n"); ;# $ftp = Fan::FTP->new( ftp_server => 'localhost', ftp_user => 'anonymous', ftp_pass => 'ikuo@intec.co.jp', ); ref($ftp) && $ftp->login && $ftp->image or print("not ok 6\n"), exit(1); print("ok 6\n"); $farm->synch($ftp, "/db/tmp/index.local") or print("not ok 7\n"), exit(1); print("ok 7\n"); ;# undef $farm; ftpmirror-1.96/Fan/HTTP/ 40755 1751 1750 0 7031563571 13123 5ustar ikuouserftpmirror-1.96/Fan/HTTP/Changes100644 1751 1750 172 6401315270 14462 0ustar ikuouserRevision history for Perl extension Fan::HTTP. 0.01 Thu Aug 21 21:20:15 1997 - original version; created by h2xs 1.18 ftpmirror-1.96/Fan/HTTP/HTTP.pm100644 1751 1750 15174 6430332324 14355 0ustar ikuouser;# ;# Copyright (c) 1995-1997 ;# 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: HTTP.pm,v 1.16 1997/11/06 12:15:16 ikuo Exp $ ;# ;# Description: ;# HTTP.pm - HTTP Class definitions ;# - Socket based operations. ;# - Multiple addresses for a single server are supported. ;# - Multiple sessions are supported. ;# ;# Usage: ;# package Fan::HTTP; use strict; use vars qw($VERSION @ISA $LOG $http_port); use Carp; use Fan::Cool; use Fan::TCP; use AutoLoader 'AUTOLOAD'; @ISA = qw(Fan::TCP); $VERSION = '0.02'; $LOG = 5 unless defined($LOG); ;# A special marker for AutoSplit. 1; __END__ ;# destroy an object. sub DESTROY ($) { my $self = shift; # log... carp("HTTP DESTROYING $self") if $LOG >= 6; # destroy this object in SUPER class. Fan::TCP::DESTROY($self); } ;# creat a new object. sub new ($%) { my $this = shift; my $class = ref($this) || $this; my %param = @_; # if we required verbose log, set tcp_debug $param{tcp_debug} = 1 if $LOG > 5; # bless myself. my $self = bless Fan::TCP->new(%param), $class; ref($self) or return undef; # log... carp("HTTP CREATING $self") if $LOG >= 6; # result is myself. $self; } ;# connecting the server, and get contents. sub get ($$;$) { my $self = shift; my ($proto, $server, $port, $document) = &parse_url(shift); my $out = shift; my $tmp; my $need_rename = 0; my $fh; local *OUTPUT; if ($document !~ /^\//) { carp("$self: document must begin with a slash"), return undef; } if ($out eq '') { $fh = \*STDOUT; } elsif (ref($out) eq 'GLOB') { $fh = $out; } else { ($tmp = $out) =~ s%[^/]+$%.in.$&%; $need_rename++; CORE::open(OUTPUT, ">$tmp") or carp("$self: open($tmp) - $!"), return undef; $fh = \*OUTPUT; } $proto = $self->{http_proto} if $proto eq ''; $proto = 'http' if $proto eq ''; $server = $self->{http_server} if $server eq ''; if ($server eq '') { carp("$self: host not specified"), return undef; } if ($self->{http_proxy} eq '') { if ($proto ne 'http') { carp("$self: protocol $proto is not supported"); return undef; } $port = 80 if $port eq ''; } else { if (defined($port)) { # normal port $document = sprintf("%s://%s:%d%s", $proto, $server, $port, $document); } else { $document = sprintf("%s://%s%s", $proto, $server, $document); } $server = $self->{http_proxy}; $port = $server =~ s/:(\d+)$// ? $1 : 80; } # carp("$self: ($proto, $server, $port, $document)") if $LOG > 6; warn("HTTP: try to connect $server:$port\n") if $LOG > 6; warn("HTTP: try to get $document\n") if $LOG > 6; unless ($self->do_client(tcp_host => $server, tcp_port => $port)) { # error string was stored by do_client. $self->close; return undef; } $self->putln("GET $document HTTP/1.0") && $self->putln("Accept: */*") && $self->putln("User-Agent: HTTP.pm/$VERSION") && $self->putln("") or $self->close, return undef; defined($_ = $self->getln) && /^HTTP\/\d+\.\d+ (\d\d\d) (.+)$/ or $self->error("wrong response"), $self->close, return undef; my $result = $1; my $reason = $2; my @headers = (); warn("HTTP: result=$result reason=$2\n") if $LOG > 6; my $null = 0; while (defined($_ = $self->getln)) { $null++, last if /^$/; $_ = pop(@headers).$_ if /^\s/; push(@headers, $_); } unless ($null) { $self->error("unexpected end of file"); $self->close; return undef; } # parsing headers while (@headers) { $_ = shift(@headers); unless (s/^([a-zA-Z\-]+):\s+//) { $self->error("wrong header"); $self->clsoe; return undef; } my $tag = "\L$1"; if ($tag eq 'content-type') { if (/\s*([-\w]+)\/([-\w]+)\s*(;\s*([^\s;]+)\s*)*$/) { $self->{content_type} = $1; $self->{content_subtype} = $2; } } elsif ($tag eq 'content-length') { $self->{content_length} = $_; } elsif ($tag eq 'content-encoding') { $self->{content_encoding} = $_; } elsif ($tag eq 'content-transfer-encoding') { $self->{content_transfer_encoding} = $_; } elsif ($tag eq 'last-modified') { $self->{last_modified} = $_; } else { # simply ignored } } # get total length of this contents my $length = defined($self->{content_length}) ? $self->{content_length} + 0 : undef; # try to read real data. my $len = 0; my $ll = defined($length) && $length < 10240 ? $length : 10240; while ($ll > 0 && defined(my $data = $self->getdata($ll))) { unless (print $fh $data) { $self->error($!.''); $self->close; return undef; } $len += length($data); $ll = defined($length) && $length - $len < 10240 ? $length - $len : 10240; } # o.k., now close this session. $self->close; if ($self->error) { return undef; } # checking result... unless ($result == 200) { $self->error("\"$reason\""); return undef; } # check length... if (defined($length) && $length != $len) { $self->error('length mismatch'); return undef; } # rename if we wrote to a plain file if ($need_rename) { unless (rename($tmp, $out)) { my $e = $!.""; $self->error("rename($out): $e"); return undef; } } # success 1; } ;# sub parse_url ($) { local $_ = shift; my $proto = s|^(\w+)://|| ? $1 : undef; my $server = s|^([^/]+)|| ? $1 : undef; my $port = $server =~ s|:(\d+)$|| ? $1 : undef; my $document = m|^/| ? $_ : '/'; carp("HTTP parse_url: ($proto, $server, $port, $document)") if $LOG > 6; ($proto, $server, $port, $document); } ;# end of Fan::HTTP module ftpmirror-1.96/Fan/HTTP/MANIFEST100644 1751 1750 55 6401315271 14301 0ustar ikuouserChanges HTTP.pm MANIFEST Makefile.PL test.pl ftpmirror-1.96/Fan/HTTP/Makefile.PL100644 1751 1750 211 6401315271 15134 0ustar ikuouseruse ExtUtils::MakeMaker; WriteMakefile( 'NAME' => 'Fan::HTTP', 'VERSION_FROM' => 'HTTP.pm', 'clean' => { 'FILES' => 'tmp.out' }, ); ftpmirror-1.96/Fan/HTTP/test.pl100644 1751 1750 1036 6406754576 14550 0ustar ikuouserBEGIN { $| = 1; print("1..3\n"); } END { print("not ok 1\n") unless $loaded; } sub prompt { my $prompt = shift; local $_; print STDERR $prompt; defined($_ = ) || return undef; chomp; $_; } use Fan::HTTP; $loaded = 1; print("ok 1\n"); $proxy = &prompt("proxy: "); $url = &prompt("url: "); ref($http = Fan::HTTP->new(http_proxy => $proxy)) or print("not ok 2\n"), exit(1); print("ok 2\n"); $http->get($url, "tmp.out") or print("not ok 3\n"), exit(1); print("ok 3\n"); print("check tmp.out to see contents of $url.\n"); ftpmirror-1.96/Fan/Loader/ 40755 1751 1750 0 7031563572 13553 5ustar ikuouserftpmirror-1.96/Fan/Loader/Changes100644 1751 1750 174 6401315274 15117 0ustar ikuouserRevision history for Perl extension Fan::Loader. 0.01 Sat Aug 23 13:10:23 1997 - original version; created by h2xs 1.18 ftpmirror-1.96/Fan/Loader/Loader.pm100644 1751 1750 22240 6412637241 15431 0ustar ikuouser;# ;# Copyright (c) 1995-1997 ;# 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: Loader.pm,v 1.22 1997/09/26 04:48:33 ikuo Exp $ ;# package Fan::Loader; use strict; use vars qw($VERSION $LOG); use Carp; use Fan::Param; use AutoLoader 'AUTOLOAD'; $VERSION = '0.02'; $LOG = 5; ;# A special marker for AutoSplit. 1; __END__ ;# sub DESTROY ($) { my $self = shift; carp("Loader DESTROYING $self") if $LOG >= 6; } ;# sub new ($;%) { my $this = shift; my $class = ref($this) || $this; my %param = @_; my $keys = $param{loader_keys}; my $nest = $param{loader_nest}; my $self = { loader_keys => ref($keys) eq 'HASH' ? $keys : undef, loader_nest => ref($nest) eq 'HASH' ? $nest : undef, loader_db => {}, loader_current => 'DEFAULT' }; bless $self, $class or croak("Loader::new bless: $!"); carp("Loader CREATING $self") if $LOG >= 6; $self; } ;# ;# $loader->search($package_name [, $create]); ;# sub search ($;$$) { my $self = shift; my $name = shift; my $genflag = shift; $name = $self->{loader_current} if $name eq ''; $name ne '' or confess("Empty name was detected"); # Is there a database for given name? my $p = $self->{loader_db}->{$name}; # Check value and create a new one if needed. if (!ref($p)) { # $p->isa('Fan::Param') must also be true. unless ($genflag) { #warn("search: $name not found.\n"); # We can't generate a new one. return undef; # simply return FALSE. } $p = Fan::Param->new( param_name => $name, param_keys => $self->{loader_keys} ); ref($p) or carp("Can't create Param object"), return undef; $self->{loader_db}->{$name} = $p; #warn("search: $name = $p created.\n"); } # DEBUG only ref($p) && $p->isa('Fan::Param') or confess("$p must be a Param object"); # Register this object as `current' param. $self->{loader_current} = $name; #warn("search: $name = $p found.\n"); # return Param object. $p; } ;# ;# undef name ... clear a variable `name'. ;# name ... set the value of `name' to 1. ;# name = value ... set the value of `name' to `value'. ;# name += value ... add \n + `value' to `name'. ;# ;# 1 will be returned on success. ;# when name has special meaning,... what shall we do? ;# sub parse_line ($$;$) { my $self = shift; my $nest = $self->{loader_nest}; # hash ref. local $_ = shift; # an input line. my $param = @_ ? shift : ''; # Param object or Param name. my $p; # check param... if (ref($param) && $param->isa('Fan::Param')) { $p= $param; } else { ref($p= $self->search($param, 1)) && $p->isa('Fan::Param') or confess("Can't get a Param object for $param"); } # Trim leading/trailing spaces. s/^\s+//; s/\s+$//; # Skip comment or null lines. return 0 if /^$/ || /^#/; # Set default value of the result. my($key, $val, $todo); # Parse this line. if (/^$/ || /^#/) { # skip comment lines. return ''; } elsif (/^delete\s+/) { # delete variable. ($key, $val, $todo) = ($', undef, 'delete'); } elsif (/^undef\s+/) { # set undef... TO BE FIXED. ($key, $val, $todo) = ($', '', 'setval'); } elsif (/\s*\+=\s*/) { # add value. ($key, $val, $todo) = ($`, $', 'addval'); } elsif (/\s*=\s*/) { # set value. ($key, $val, $todo) = ($`, $', 'setval'); } else { # set to 1. ($key, $val, $todo) = ($_, 1, 'setval'); } # Convert `-' to `_'. $key =~ y/-/_/; #warn("loader: key=$key, val=$val, todo=$todo\n"); # Check special action. if (ref($nest) eq 'HASH' && exists($nest->{$key})) { my $s = $nest->{$key}; # make a copy... my $result; if ($s =~ s/^!//) { local $_ = $val; $result = eval $s; croak("loader: ".$@) if $@; } else { ($result = $s) =~ s/\$_/$val/g; } if (!defined($result)) { croak("loader: wrong usage of $key"); } if ($result eq '') { croak("loader: empty name found"); } return $result; } # To check errors. my $err = 0; # Do real action. if ($todo eq '') { ; } elsif ($todo eq 'delete') { $err++ if !defined($p->delete($key)); } elsif ($todo eq 'addval') { $err++ if !defined($p->addval($key, $val)); } elsif ($todo eq 'setval') { $err++ if !defined($p->setval($key, $val)); } else { # what? this can't be happen. confess("loader: unexpected todo"); } # Check the result. if ($err) { croak("loader: \"$key\" unrecognized parameter"); } # Result is an empty string for normal cases. ''; } ;# ;# $p->parse_option(\@ARRAY); ;# sub parse_option ($\@;$) { my $self = shift; # loader my $array = shift; # reference to ARRAY my $param_name = @_ ? shift : ''; my $p = $self->search($param_name, 1); # DEBUG only ref($p) && $p->isa('Fan::Param') or confess("$p must be a Param object"); # Array format is "--tag=value". while (@{$array} && ${$array}[$[] =~ s/^--//) { my $x = $self->parse_line(shift(@{$array}), $p); if (!defined($x)) { croak("loader: error found in parse_option"); } elsif ($x eq '') { # good. ; } else { $p = $self->search($x, 1); # DEBUG only ref($p) && $p->isa('Fan::Param') or confess("$p must be a Param object"); } } # This routine returns # of (key, val) pairs we changed. 1; } ;# Load file and set parameters. ;# ;# $p->parse_file(filename); ;# sub parse_file ($$;$) { my $self = shift; my $file = shift; my $param_name = @_ ? shift : ''; my $p = $self->search($param_name, 1); # DEBUG only ref($p) && $p->isa('Fan::Param') or confess("$p must be a Param object"); # Check filename, add prefix is filename is relative path. if ($file !~ /^\// && $self->{loader_prefix} ne '') { $file = $self->{loader_prefix}.'/'.$file; } # Open file local *FILE; unless (open(FILE, $file)) { carp("$self: open($file) - $!") if $LOG > 4; return undef; } # Reading lines my $line = ''; local $_; while () { # strip CR/LF at end. chomp; s/\r?$//; # for cont'd lines if ($line ne '') { s/^\s+// ; # strip leading spaces $_ = $line.$_; # concat to saved line } $line = $_, next if s/\\$//; # cont'd line # found one line. $line = ''; # clear # trim leading/trailing spaces, and skip comment lines. s/^\s+//; s/\s+$//; next if /^$/ || /^#/; # try to parse, and check result my $x = $self->parse_line($_, $p); if (!defined($x)) { croak("$file($.): error was detected"); } elsif ($x eq '') { # good. ; } else { $p = $self->search($x, 1); # DEBUG only ref($p) && $p->isa('Fan::Param') or confess("$p must be a Param object"); } } # we may be able to comment out the next line. close(FILE); # Returns # of ($key, $val) pairs we changed. 1; } ;# ;# $loader->combine_hash(\%hash [, 'PARAM_NAME' [, $override]]) ;# sub combine_hash ($\%;$$) { my $self = shift; my $hash = shift; my $param_name = @_ ? shift : ''; my $p = $self->search($param_name, 1); my $f = shift; ref($hash) eq 'HASH' or carp("$hash must be HASH"), return undef; my $param = Fan::Param->new( param_name => 'temp', param_keys => $self->{loader_keys}, %{$hash}); ref($param) && $param->isa('Fan::Param') or return undef; $p->combine($param, $f); } ;# sub merge_hash ($\%;$) { my $self = shift; my $hash = shift; my $param_name = @_ ? shift : ''; my $p = $self->search($param_name, 1); my $f = shift; $self->combine_hash($hash, $param_name, 1); } ;# dump all Param objects in registry. sub dumpall ($) { my $self = shift; # loader my $name; my $param; while (($name, $param) = each %{$self->{loader_db}}) { $param->dump; } } ;# ;# $loader->get_value('key-you-want', 'key-of-param', 'key-of-param',...); ;# sub get_value ($$@) { my $self = shift; my $want = shift; my @keys = @_; my $val = undef; # warn("try get value of \"$want\" from (".join(', ', @keys).")\n"); while (@keys) { my $key = pop(@keys); my $p = $self->{loader_db}->{$key}; if (ref($p) && $p->isa('Fan::Param')) { # warn(" try $key\n"); my $v = $p->getval($want); if (defined($v)) { $val = $v.$val; # warn(" found val = $v\n"); last if $v !~ /^\n/; } } } # not found... # { my $v = $val; $v =~ s/\n/ /g; warn(" returning val = $v\n"); } $val; } ;# end of Fan::Loader module ftpmirror-1.96/Fan/Loader/MANIFEST100644 1751 1750 57 6377717177 14761 0ustar ikuouserLoader.pm Changes MANIFEST Makefile.PL test.pl ftpmirror-1.96/Fan/Loader/Makefile.PL100644 1751 1750 146 6401315275 15576 0ustar ikuouseruse ExtUtils::MakeMaker; WriteMakefile( 'NAME' => 'Fan::Loader', 'VERSION_FROM' => 'Loader.pm', ); ftpmirror-1.96/Fan/Loader/test.pl100644 1751 1750 6112 6404275310 15155 0ustar ikuouserBEGIN { $| = 1; print "1..8\n"; $tmpfile = 'tmp.cf'; } END { print("not ok 1\n") unless $loaded; $loader->dumpall if ref($loader) && !$good; unlink($tmpfile) if -e $tmpfile; } use Fan::Loader; $loaded = 1; print("ok 1\n"); # $Fan::Loader::LOG = 7; # $Fan::Param::LOG = 7; ## start up %hash_keys = ( 'sysconfdir' => 'DIRECTORY', 'load-config' => '', 'log-mask' => '', 'put-mode' => 'BOOLEAN', 'ftp-server' => '', 'ftp-gateway' => '', 'ftp-timeout' => 'INTEGER', 'ftp-passive' => 'BOOLEAN', 'ftp-user' => '', 'ftp-pass' => '', 'ftp-debug' => 'BOOLEAN', 'ftp-list-method' => 's/^(LIST|STAT)$/\U$1/i || undef', 'unlink' => '$_ = $_ eq "rename" ? 2 : &Fan::Param::want_boolean($_)', 'transfer-file-regexp' => '', 'transfer-directory-regexp' => '', 'override-file-regexp' => '', 'override-directory-regexp' => '', 'temp-directory' => 'DIRECTORY', 'remote-directory' => '', 'local-directory' => '', 'remote-db-directory' => '', 'local-db-directory' => '', 'master-db-directory' => '', 'lock-directory' => '', ); %hash_nest = ( 'archive' => 'PACKAGE::$_', 'package' => 'PACKAGE::$_', 'server' => 'PACKAGE::$_', ); open(FILE, ">$tmpfile") or print("not ok 2\n"), exit(1); print FILE <<"EOT"; package = utils$$ ftp-server = ftp$$.intec.co.jp remote-directory = /pub/utils$$ local-directory = /pub/utils$$ EOT close(FILE); $loader = Fan::Loader->new( loader_keys => \%hash_keys, loader_nest => \%hash_nest ); ref($loader) && $loader->isa('Fan::Loader') or print("not ok 2\n"), exit(1); print("ok 2\n"); ## from hash %init_hash = ( 'sysconfdir' => '../..', 'load-config' => 'ftpmirror.cf-sample', 'temp-directory' => '/tmp', ); $loader->combine_hash(\%init_hash, 'INIT') or print("not ok 3\n"), exit(1); print("ok 3\n"); ## from options @lines = ( "--log-mask=main=7", "--load-config+=$tmpfile", "--ftp-passive=yes" ); $loader->parse_option(\@lines, 'OPTION') or print("not ok 4\n"), exit(1); print("ok 4\n"); ## check result $param = $loader->search('OPTION'); ref($param) && $param->isa('Fan::Param') or print("not ok 5\n"), exit(1); print("ok 5\n"); ## get value $sysconfdir = $loader->get_value('sysconfdir', 'INIT', 'OPTION'); $sysconfdir ne '' && -d $sysconfdir or print("not ok 6\n"), exit(1); print("ok 6\n"); ## parsing... $default = $loader->get_value('load-config', 'INIT', 'OPTION'); for my $file (split(/\n/, $default)) { if ($file eq '') { print("ignore null string\n"); # ingore } else { $file = "$sysconfdir/$file" if ! -f $file; # print("parsing $file...\n"); $loader->parse_file($file, 'DEFAULT') or print("not ok 7\n"), exit(1); } } print("ok 7\n"); # $param = $loader->search("PACKAGE::utils$$"); ref($param) && $param->isa('Fan::Param') or print("not ok 8 (search)\n"), exit(1); $param->getval('ftp-server') eq "ftp$$.intec.co.jp" or print("not ok 8 (ftp-server)\n"), exit(1); $param->getval('remote-directory') eq "/pub/utils$$" or print("not ok 8 (remote-directory)\n"), exit(1); $param->getval('local-directory') eq "/pub/utils$$" or print("not ok 8 (local-directory)\n"), exit(1); print("ok 8\n"); $good = 1; ftpmirror-1.96/Fan/MD5/ 40755 1751 1750 0 7031563573 12733 5ustar ikuouserftpmirror-1.96/Fan/MD5/Changes100644 1751 1750 171 6401315277 14276 0ustar ikuouserRevision history for Perl extension Fan::MD5. 0.01 Thu Aug 21 21:52:14 1997 - original version; created by h2xs 1.18 ftpmirror-1.96/Fan/MD5/MANIFEST100644 1751 1750 112 6377516666 14150 0ustar ikuouserChanges MANIFEST MD5.pm MD5.xs Makefile.PL global.h md5.h test.pl typemap ftpmirror-1.96/Fan/MD5/MD5.pm100644 1751 1750 4435 6600625703 13754 0ustar ikuouser;# ;# 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: MD5.pm,v 1.13 1998/09/19 03:57:55 ikuo Exp $ ;# package Fan::MD5; use strict; use vars qw($VERSION @ISA @EXPORT); require Exporter; require DynaLoader; use AutoLoader 'AUTOLOAD'; @ISA = qw(Exporter DynaLoader); @EXPORT = qw(MD5Init MD5Update MD5Final MD5File MD5String); $VERSION = '0.03'; ;# proptotypes ;# sub MD5Init (); ;# sub MD5Update ($$;$); ;# sub MD5Final ($); ;# sub MD5File ($); ;# sub MD5String ($); bootstrap Fan::MD5 $VERSION; ;# ;# A special marker for AutoSplit. 1; __END__ sub MD5File ($) { my $file = shift; my $p = &MD5Init; my $length; local(*FILE, $_); open(FILE, $file) || return undef; while (($length = sysread(FILE, $_, 1024)) > 0) { &MD5Update($p, $_, $length); } close(FILE); my $str = &MD5Final($p); undef $p; $str; } sub MD5String ($) { my $string = shift; my $p = &MD5Init; &MD5Update($p, $string, length($string)); my $str = &MD5Final($p); undef $p; $str; } ;# end of Fan::MD5 module ftpmirror-1.96/Fan/MD5/MD5.xs100644 1751 1750 30514 6600637132 14006 0ustar ikuouser/* MD5C.C - RSA Data Security, Inc., MD5 message-digest algorithm */ /* Copyright (C) 1991-2, RSA Data Security, Inc. Created 1991. All rights reserved. License to copy and use this software is granted provided that it is identified as the "RSA Data Security, Inc. MD5 Message-Digest Algorithm" in all material mentioning or referencing this software or this function. License is also granted to make and use derivative works provided that such works are identified as "derived from the RSA Data Security, Inc. MD5 Message-Digest Algorithm" in all material mentioning or referencing the derived work. RSA Data Security, Inc. makes no representations concerning either the merchantability of this software or the suitability of this software for any particular purpose. It is provided "as is" without express or implied warranty of any kind. These notices must be retained in any copies of any part of this documentation and/or software. */ #include "global.h" #include "md5.h" /* for Solaris, thanks to Hatayama */ #define MD5Init MD5Init_perl #define MD5Update MD5Update_perl #define MD5Final MD5Final_perl /* Constants for MD5Transform routine. */ #define S11 7 #define S12 12 #define S13 17 #define S14 22 #define S21 5 #define S22 9 #define S23 14 #define S24 20 #define S31 4 #define S32 11 #define S33 16 #define S34 23 #define S41 6 #define S42 10 #define S43 15 #define S44 21 static void MD5Transform PROTO_LIST ((UINT4 [4], unsigned char [64])); static void Encode PROTO_LIST ((unsigned char *, UINT4 *, unsigned int)); static void Decode PROTO_LIST ((UINT4 *, unsigned char *, unsigned int)); static void MD5_memcpy PROTO_LIST ((POINTER, POINTER, unsigned int)); static void MD5_memset PROTO_LIST ((POINTER, int, unsigned int)); static unsigned char PADDING[64] = { 0x80, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 }; /* F, G, H and I are basic MD5 functions. */ #define F(x, y, z) (((x) & (y)) | ((~x) & (z))) #define G(x, y, z) (((x) & (z)) | ((y) & (~z))) #define H(x, y, z) ((x) ^ (y) ^ (z)) #define I(x, y, z) ((y) ^ ((x) | (~z))) /* ROTATE_LEFT rotates x left n bits. */ #define ROTATE_LEFT(x, n) (((x) << (n)) | ((x) >> (32-(n)))) /* FF, GG, HH, and II transformations for rounds 1, 2, 3, and 4. Rotation is separate from addition to prevent recomputation. */ #define FF(a, b, c, d, x, s, ac) { \ (a) += F ((b), (c), (d)) + (x) + (UINT4)(ac); \ (a) = ROTATE_LEFT ((a), (s)); \ (a) += (b); \ } #define GG(a, b, c, d, x, s, ac) { \ (a) += G ((b), (c), (d)) + (x) + (UINT4)(ac); \ (a) = ROTATE_LEFT ((a), (s)); \ (a) += (b); \ } #define HH(a, b, c, d, x, s, ac) { \ (a) += H ((b), (c), (d)) + (x) + (UINT4)(ac); \ (a) = ROTATE_LEFT ((a), (s)); \ (a) += (b); \ } #define II(a, b, c, d, x, s, ac) { \ (a) += I ((b), (c), (d)) + (x) + (UINT4)(ac); \ (a) = ROTATE_LEFT ((a), (s)); \ (a) += (b); \ } /* MD5 initialization. Begins an MD5 operation, writing a new context. */ void MD5Init (context) MD5_CTX *context; /* context */ { context->count[0] = context->count[1] = 0; /* Load magic initialization constants. */ context->state[0] = 0x67452301; context->state[1] = 0xefcdab89; context->state[2] = 0x98badcfe; context->state[3] = 0x10325476; } /* MD5 block update operation. Continues an MD5 message-digest operation, processing another message block, and updating the context. */ void MD5Update (context, input, inputLen) MD5_CTX *context; /* context */ unsigned char *input; /* input block */ unsigned int inputLen; /* length of input block */ { unsigned int i, index, partLen; /* Compute number of bytes mod 64 */ index = (unsigned int)((context->count[0] >> 3) & 0x3F); /* Update number of bits */ if ((context->count[0] += ((UINT4)inputLen << 3)) < ((UINT4)inputLen << 3)) context->count[1]++; context->count[1] += ((UINT4)inputLen >> 29); partLen = 64 - index; /* Transform as many times as possible. */ if (inputLen >= partLen) { MD5_memcpy ((POINTER)&context->buffer[index], (POINTER)input, partLen); MD5Transform (context->state, context->buffer); for (i = partLen; i + 63 < inputLen; i += 64) MD5Transform (context->state, &input[i]); index = 0; } else i = 0; /* Buffer remaining input */ MD5_memcpy ((POINTER)&context->buffer[index], (POINTER)&input[i], inputLen-i); } /* MD5 finalization. Ends an MD5 message-digest operation, writing the the message digest and zeroizing the context. */ void MD5Final (digest, context) unsigned char digest[16]; /* message digest */ MD5_CTX *context; /* context */ { unsigned char bits[8]; unsigned int index, padLen; /* Save number of bits */ Encode (bits, context->count, 8); /* Pad out to 56 mod 64. */ index = (unsigned int)((context->count[0] >> 3) & 0x3f); padLen = (index < 56) ? (56 - index) : (120 - index); MD5Update (context, PADDING, padLen); /* Append length (before padding) */ MD5Update (context, bits, 8); /* Store state in digest */ Encode (digest, context->state, 16); /* Zeroize sensitive information. */ MD5_memset ((POINTER)context, 0, sizeof (*context)); } /* MD5 basic transformation. Transforms state based on block. */ static void MD5Transform (state, block) UINT4 state[4]; unsigned char block[64]; { UINT4 a = state[0], b = state[1], c = state[2], d = state[3], x[16]; Decode (x, block, 64); /* Round 1 */ FF (a, b, c, d, x[ 0], S11, 0xd76aa478); /* 1 */ FF (d, a, b, c, x[ 1], S12, 0xe8c7b756); /* 2 */ FF (c, d, a, b, x[ 2], S13, 0x242070db); /* 3 */ FF (b, c, d, a, x[ 3], S14, 0xc1bdceee); /* 4 */ FF (a, b, c, d, x[ 4], S11, 0xf57c0faf); /* 5 */ FF (d, a, b, c, x[ 5], S12, 0x4787c62a); /* 6 */ FF (c, d, a, b, x[ 6], S13, 0xa8304613); /* 7 */ FF (b, c, d, a, x[ 7], S14, 0xfd469501); /* 8 */ FF (a, b, c, d, x[ 8], S11, 0x698098d8); /* 9 */ FF (d, a, b, c, x[ 9], S12, 0x8b44f7af); /* 10 */ FF (c, d, a, b, x[10], S13, 0xffff5bb1); /* 11 */ FF (b, c, d, a, x[11], S14, 0x895cd7be); /* 12 */ FF (a, b, c, d, x[12], S11, 0x6b901122); /* 13 */ FF (d, a, b, c, x[13], S12, 0xfd987193); /* 14 */ FF (c, d, a, b, x[14], S13, 0xa679438e); /* 15 */ FF (b, c, d, a, x[15], S14, 0x49b40821); /* 16 */ /* Round 2 */ GG (a, b, c, d, x[ 1], S21, 0xf61e2562); /* 17 */ GG (d, a, b, c, x[ 6], S22, 0xc040b340); /* 18 */ GG (c, d, a, b, x[11], S23, 0x265e5a51); /* 19 */ GG (b, c, d, a, x[ 0], S24, 0xe9b6c7aa); /* 20 */ GG (a, b, c, d, x[ 5], S21, 0xd62f105d); /* 21 */ GG (d, a, b, c, x[10], S22, 0x2441453); /* 22 */ GG (c, d, a, b, x[15], S23, 0xd8a1e681); /* 23 */ GG (b, c, d, a, x[ 4], S24, 0xe7d3fbc8); /* 24 */ GG (a, b, c, d, x[ 9], S21, 0x21e1cde6); /* 25 */ GG (d, a, b, c, x[14], S22, 0xc33707d6); /* 26 */ GG (c, d, a, b, x[ 3], S23, 0xf4d50d87); /* 27 */ GG (b, c, d, a, x[ 8], S24, 0x455a14ed); /* 28 */ GG (a, b, c, d, x[13], S21, 0xa9e3e905); /* 29 */ GG (d, a, b, c, x[ 2], S22, 0xfcefa3f8); /* 30 */ GG (c, d, a, b, x[ 7], S23, 0x676f02d9); /* 31 */ GG (b, c, d, a, x[12], S24, 0x8d2a4c8a); /* 32 */ /* Round 3 */ HH (a, b, c, d, x[ 5], S31, 0xfffa3942); /* 33 */ HH (d, a, b, c, x[ 8], S32, 0x8771f681); /* 34 */ HH (c, d, a, b, x[11], S33, 0x6d9d6122); /* 35 */ HH (b, c, d, a, x[14], S34, 0xfde5380c); /* 36 */ HH (a, b, c, d, x[ 1], S31, 0xa4beea44); /* 37 */ HH (d, a, b, c, x[ 4], S32, 0x4bdecfa9); /* 38 */ HH (c, d, a, b, x[ 7], S33, 0xf6bb4b60); /* 39 */ HH (b, c, d, a, x[10], S34, 0xbebfbc70); /* 40 */ HH (a, b, c, d, x[13], S31, 0x289b7ec6); /* 41 */ HH (d, a, b, c, x[ 0], S32, 0xeaa127fa); /* 42 */ HH (c, d, a, b, x[ 3], S33, 0xd4ef3085); /* 43 */ HH (b, c, d, a, x[ 6], S34, 0x4881d05); /* 44 */ HH (a, b, c, d, x[ 9], S31, 0xd9d4d039); /* 45 */ HH (d, a, b, c, x[12], S32, 0xe6db99e5); /* 46 */ HH (c, d, a, b, x[15], S33, 0x1fa27cf8); /* 47 */ HH (b, c, d, a, x[ 2], S34, 0xc4ac5665); /* 48 */ /* Round 4 */ II (a, b, c, d, x[ 0], S41, 0xf4292244); /* 49 */ II (d, a, b, c, x[ 7], S42, 0x432aff97); /* 50 */ II (c, d, a, b, x[14], S43, 0xab9423a7); /* 51 */ II (b, c, d, a, x[ 5], S44, 0xfc93a039); /* 52 */ II (a, b, c, d, x[12], S41, 0x655b59c3); /* 53 */ II (d, a, b, c, x[ 3], S42, 0x8f0ccc92); /* 54 */ II (c, d, a, b, x[10], S43, 0xffeff47d); /* 55 */ II (b, c, d, a, x[ 1], S44, 0x85845dd1); /* 56 */ II (a, b, c, d, x[ 8], S41, 0x6fa87e4f); /* 57 */ II (d, a, b, c, x[15], S42, 0xfe2ce6e0); /* 58 */ II (c, d, a, b, x[ 6], S43, 0xa3014314); /* 59 */ II (b, c, d, a, x[13], S44, 0x4e0811a1); /* 60 */ II (a, b, c, d, x[ 4], S41, 0xf7537e82); /* 61 */ II (d, a, b, c, x[11], S42, 0xbd3af235); /* 62 */ II (c, d, a, b, x[ 2], S43, 0x2ad7d2bb); /* 63 */ II (b, c, d, a, x[ 9], S44, 0xeb86d391); /* 64 */ state[0] += a; state[1] += b; state[2] += c; state[3] += d; /* Zeroize sensitive information. */ MD5_memset ((POINTER)x, 0, sizeof (x)); } /* Encodes input (UINT4) into output (unsigned char). Assumes len is a multiple of 4. */ static void Encode (output, input, len) unsigned char *output; UINT4 *input; unsigned int len; { unsigned int i, j; for (i = 0, j = 0; j < len; i++, j += 4) { output[j] = (unsigned char)(input[i] & 0xff); output[j+1] = (unsigned char)((input[i] >> 8) & 0xff); output[j+2] = (unsigned char)((input[i] >> 16) & 0xff); output[j+3] = (unsigned char)((input[i] >> 24) & 0xff); } } /* Decodes input (unsigned char) into output (UINT4). Assumes len is a multiple of 4. */ static void Decode (output, input, len) UINT4 *output; unsigned char *input; unsigned int len; { unsigned int i, j; for (i = 0, j = 0; j < len; i++, j += 4) output[i] = ((UINT4)input[j]) | (((UINT4)input[j+1]) << 8) | (((UINT4)input[j+2]) << 16) | (((UINT4)input[j+3]) << 24); } /* Note: Replace "for loop" with standard memcpy if possible. */ static void MD5_memcpy (output, input, len) POINTER output; POINTER input; unsigned int len; { unsigned int i; for (i = 0; i < len; i++) output[i] = input[i]; } /* Note: Replace "for loop" with standard memset if possible. */ static void MD5_memset (output, value, len) POINTER output; int value; unsigned int len; { unsigned int i; for (i = 0; i < len; i++) ((char *)output)[i] = (char)value; } /* * Note: Perl5 extension. * Extended by Ikuo Nakagawa. */ #ifdef XS_VERSION #ifdef __cplusplus extern "C" { #endif #include "EXTERN.h" #include "perl.h" #include "XSUB.h" #ifdef __cplusplus } #endif #endif /* XS_VERSION */ static int not_here(s) char *s; { croak("%s not implemented on this architecture", s); return -1; } static double constant(name, arg) char *name; int arg; { errno = 0; switch (*name) { case 'M': if (strEQ(name, "MD")) #ifdef MD return MD; #else goto not_there; #endif break; } errno = EINVAL; return 0; not_there: errno = ENOENT; return 0; } MODULE = Fan::MD5 PACKAGE = Fan::MD5 MD5_CTX * MD5Init() PROTOTYPE: CODE: { SV *sv = perl_get_sv("Fan::MD5::LOG", FALSE); int log = sv ? SvIV(sv) : 5; if (!(RETVAL = malloc(sizeof(MD5_CTX)))) XSRETURN_UNDEF; MD5Init(RETVAL); if (log > 5) { printf("Fan::MD5 CREATING = %p\n", RETVAL); fflush(stdout); } ST(0) = sv_newmortal(); sv_setref_pv(ST(0), "MD5_CTXPtr", (void*)RETVAL); } void MD5Update(pctx, buf, len = -1) MD5_CTX * pctx char * buf int len PROTOTYPE: $$;$ CODE: { if (len < 0) { len = buf ? strlen(buf) : 0; } MD5Update(pctx, buf, len); } char * MD5Final(pctx) MD5_CTX * pctx PROTOTYPE: $ CODE: { int i; unsigned char digest[16]; char result[40]; MD5Final(digest, pctx); #define tohex(c) ((c) > 9 ? (c) - 10 + 'a' : (c) + '0') for (i = 0; i < 16; i++) { int x, y; x = digest[i] & 0x0f; y = (digest[i] >> 4) & 0x0f; result[i * 2] = tohex(y); result[i * 2 + 1] = tohex(x); } result[32] = '\0'; ST(0) = sv_newmortal(); sv_setpv(ST(0), result); } MODULE = Fan::MD5 PACKAGE = MD5_CTXPtr PREFIX = MD5_ void MD5_DESTROY(pctx) MD5_CTX *pctx; CODE: { SV *sv = perl_get_sv("Fan::MD5::LOG", FALSE); int log = sv ? SvIV(sv) : 5; if (log > 5) { printf("Fan::MD5 DESTROYING = %p\n", pctx); fflush(stdout); } free(pctx); } ftpmirror-1.96/Fan/MD5/Makefile.PL100644 1751 1750 140 6401315300 14734 0ustar ikuouseruse ExtUtils::MakeMaker; WriteMakefile( 'NAME' => 'Fan::MD5', 'VERSION_FROM' => 'MD5.pm', ); ftpmirror-1.96/Fan/MD5/global.h100644 1751 1750 1415 6377516666 14457 0ustar ikuouser/* GLOBAL.H - RSAREF types and constants */ /* PROTOTYPES should be set to one if and only if the compiler supports function argument prototyping. The following makes PROTOTYPES default to 0 if it has not already been defined with C compiler flags. */ #ifndef PROTOTYPES #define PROTOTYPES 0 #endif /* POINTER defines a generic pointer type */ typedef unsigned char *POINTER; /* UINT2 defines a two byte word */ typedef unsigned short int UINT2; /* UINT4 defines a four byte word */ typedef unsigned long int UINT4; /* PROTO_LIST is defined depending on how PROTOTYPES is defined above. If using PROTOTYPES, then PROTO_LIST returns the list, otherwise it returns an empty list. */ #if PROTOTYPES #define PROTO_LIST(list) list #else #define PROTO_LIST(list) () #endif ftpmirror-1.96/Fan/MD5/md5.h100644 1751 1750 2523 6377516666 13705 0ustar ikuouser/* MD5.H - header file for MD5C.C */ /* Copyright (C) 1991-2, RSA Data Security, Inc. Created 1991. All rights reserved. License to copy and use this software is granted provided that it is identified as the "RSA Data Security, Inc. MD5 Message-Digest Algorithm" in all material mentioning or referencing this software or this function. License is also granted to make and use derivative works provided that such works are identified as "derived from the RSA Data Security, Inc. MD5 Message-Digest Algorithm" in all material mentioning or referencing the derived work. RSA Data Security, Inc. makes no representations concerning either the merchantability of this software or the suitability of this software for any particular purpose. It is provided "as is" without express or implied warranty of any kind. These notices must be retained in any copies of any part of this documentation and/or software. */ /* MD5 context. */ typedef struct { UINT4 state[4]; /* state (ABCD) */ UINT4 count[2]; /* number of bits, modulo 2^64 (lsb first) */ unsigned char buffer[64]; /* input buffer */ } MD5_CTX; #if 0 void MD5Init PROTO_LIST ((MD5_CTX *)); void MD5Update PROTO_LIST ((MD5_CTX *, unsigned char *, unsigned int)); void MD5Final PROTO_LIST ((unsigned char [16], MD5_CTX *)); #endif ftpmirror-1.96/Fan/MD5/test.pl100644 1751 1750 3116 6401315301 14325 0ustar ikuouserBEGIN { $| = 1; print "1..1\n"; } END { print("not ok 1\n") unless $loaded; } use Fan::MD5; use strict; use vars qw($loaded %hash_data %hash_file $err); $loaded = 1; print "ok 1\n"; $Fan::MD5::LOG = 6; # $str{n_0_9} = join('', '0'..'9'); # $str{n_a_z} = join('', 'a'..'z'); # $str{n_A_Z} = uc($str{n_a_z}); %hash_data = ( '' => 'd41d8cd98f00b204e9800998ecf8427e', 'a' => '0cc175b9c0f1b6a831c399e269772661', 'abc' => '900150983cd24fb0d6963f7d28e17f72', '0123456789' => '781e5e245d69b566979b86e28d23f2c7', 'abcdefghijklmnopqrstuvwxyz', => 'c3fcd3d76192e4007dfb496cca67e13b', 'ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789' => 'd174ab98d277d9f5a5611c2c9f419d9f', '0123456789' x 5, => 'baed005300234f3d1503c50a48ce8e6f', ); %hash_file = ( 'global.h' => '7af058e80a1ef5f247a36dc063476c46', 'rfc1321.txt', => '754b9db19f79dbc4992f7166eb0f37ce', ); # clear counter $err = 0; ### for my $key (keys %hash_data) { my $val = $hash_data{$key}; my $ret = MD5String($key); print("try dat a: $key\n"); if ($val eq $ret) { print(" : $ret ... o.k.\n"); } else { print(" : $ret ... should be $val\n"), $err++; } } $err == 0 or print("not ok 2\n"), exit(1); print("ok 2\n"); ### for my $key (keys %hash_file) { my $val = $hash_file{$key}; print("file $key not found\nnot ok 3\n"), exit(1) if ! -f $key; my $ret = MD5File($key); print("try file : $key\n"); if ($val eq $ret) { print(" : $ret ... o.k.\n"); } else { print(" : $ret ... should be $val\n"), $err++; } } $err == 0 or print("not ok 3\n"), exit(1); print("ok 3\n"); ftpmirror-1.96/Fan/MD5/typemap100644 1751 1750 33 6377516666 14403 0ustar ikuouserTYPEMAP MD5_CTX * T_PTROBJ ftpmirror-1.96/Fan/Param/ 40755 1751 1750 0 7031563573 13406 5ustar ikuouserftpmirror-1.96/Fan/Param/Changes100644 1751 1750 173 6401315302 14740 0ustar ikuouserRevision history for Perl extension Fan::Param. 0.01 Thu Aug 21 21:20:16 1997 - original version; created by h2xs 1.18 ftpmirror-1.96/Fan/Param/MANIFEST100644 1751 1750 56 6401315302 14556 0ustar ikuouserChanges MANIFEST Makefile.PL Param.pm test.pl ftpmirror-1.96/Fan/Param/Makefile.PL100644 1751 1750 144 6401315303 15416 0ustar ikuouseruse ExtUtils::MakeMaker; WriteMakefile( 'NAME' => 'Fan::Param', 'VERSION_FROM' => 'Param.pm', ); ftpmirror-1.96/Fan/Param/Param.pm100644 1751 1750 26226 6600625753 15131 0ustar ikuouser;# ;# 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: Param.pm,v 1.19 1998/09/19 03:58:35 ikuo Exp $ ;# ;# Useful libraries to treat parameters. ;# ;# $param = Fan::Param->new( ;# param_name => 'INIT', ;# %param_values); ;# ;# $defaults = Fan::Param->new( ;# param_name => 'DEFAULT', ;# param_prefix => "/usr/local/etc", ;# param_file => "param.conf"); ;# ;# $options = Fan::Param->new( ;# param_name => 'OPTION', ;# param_array => \@ARGV); ;# ;# Since any key begins with 'param_' has special meaning for ;# Param package, the first statement in above, %param_value ;# can have no assoc key whose name begins with 'param_'. ;# ;# You can also combine parameters, as: ;# ;# my $override = 1; ;# $param = Fan::Param->new(param_name => "TARGET"); ;# $param->combine($init, $override); ;# $param->combine($defaults, $override); ;# $param->combine($options, $override); ;# ;# These statements are equevalent with: ;# ;# $param = Fan::Param->new(param_name => "TARGET"); ;# $param->merge($init, $defaults, $options); ;# ;# You can access to any values in a Param object as follows: ;# ;# $param->getval('key-to-access'); ;# $param->setval('key-to-access', 'value-to-set'); ;# ;# You can restrict to set values for unexpected keys with ;# `param_keys' values for a Param object. For example, ;# ;# %param_default = ( ;# "key_any" => '', # any value ;# "key_digit" => '/^\d+$/ || undef', # only digits ;# "key_ipaddr" => '/^\d+\.\d+\.\d+\.\d+$/ || undef', ;# # ip address ;# "key_range" => '$_ >= 100 && $_ < 200 || undef', ;# # number range ;# "key_path" => '-f $_ || undef' # real path ;# "key_abspath" => '/^\// || undef', # absolute path ;# "key_proc" => \&callproc # procedure ;# ); ;# $param = Fan::Param->new( ;# param_name => 'PARAM WE WILL ACCESS', ;# param_keys => \%default_default); ;# ;# if you initialize $param as above, ;# ;# $param->setval('not_in_default', 'any_value'), ;# ;# will do nothing and simply returns undef. You can modify ;# $param{$key} only if $param_default{$key} exists and the ;# evaluation of ;# ;# $_ = $val; ;# eval $param_default{$key}; ;# ;# returns non zero. ;# package Fan::Param; use strict; use vars qw($VERSION $LOG $param_sequence %wants); use Carp; use AutoLoader 'AUTOLOAD'; $VERSION = '0.03'; $LOG = 5; # notice level... ;# Sequencial number for Param objects. $param_sequence = 0; ;# prototypes. sub DESTROY ($); sub new ($%); sub error ($;$); sub try_check ($$;$); sub getval ($$); sub delete ($$); sub setval ($$$); sub addval ($$$); sub dump ($); sub combine ($@); sub merge ($@); ;# internal routines. sub want_ref; sub want_code; sub want_hash; sub want_array; sub want_boolean; sub want_integer; sub want_octal; sub want_ipv4_addr; sub want_path; sub want_file; sub want_directory; sub want_timezone; ;# initialize want hash %wants = ( 'REF' => \&want_ref, 'CODE' => \&want_code, 'HASH' => \&want_hash, 'ARRAY' => \&want_array, 'BOOLEAN' => \&want_boolean, 'INTEGER' => \&want_integer, 'OCTAL' => \&want_octal, 'IPv4_ADDR' => \&want_ipv4_addr, 'PATH' => \&want_path, 'FILE' => \&want_file, 'DIRECTORY' => \&want_directory, 'TIMEZONE' => \&want_timezone, ); ;# ;# A special marker for AutoSplit. 1; __END__ ;# Destroy a Param object. ;# sub DESTROY ($) { my $self = shift; # Log message for debugging purpose carp("Param DESTROYING $self [$self->{param_name}]") if $LOG > 5; } ;# Create a new Param object. ;# sub new ($%) { my $this = shift; my $class = ref($this) || $this; my %param = @_; my $self = { param_error => 0 }; # Count up param objects. $param_sequence++; # Pick up some special parameters. $self->{param_name} = $param{param_name} || "Param[$param_sequence]"; # Check keys param object. if (ref($param{param_keys}) eq 'HASH') { $self->{param_keys} = $param{param_keys}; # save ref } # Check keys for nesting parameters. if (ref($param{param_nest}) eq 'HASH') { $self->{param_nest} = $param{param_nest}; # save ref } # Create a new object. bless $self, $class or return undef; # Log message for debugging purpose carp("Param CREATING $self [$self->{param_name}]") if $LOG > 5; # Register (key, val) pairs in %param. my $key; my $val; while (($key, $val) = each %param) { $self->setval($key, $val) if $key !~ /^param_/; } # Return myself. $self; } ;# sub error ($;$) { my $self = shift; if (@_) { $self->{param_error} = shift; } $self->{param_error}; } ;# ;# sub addkey ($$;$) { my $p = shift; my $key = shift; my $val = @_ ? shift : ''; $p->{param_keys}->{$key} = $val; } ;# ;# sub try_check ($$;$) { my $p = shift; my $key = shift; my $h = $p->{param_keys}; # hash for keys local $_ = 1; # default return value. # Validation of the given key. if ($key =~ /^param_/ || (ref($h) eq 'HASH' && !exists($h->{$key}))) { # carp("$p: key=$key invalid key") if $LOG > 4; confess("$p: key=$key invalid key") if $LOG > 4; $p->{param_error}++; return undef; } # Validation of the given value, if exists. if (@_ && ref($h) eq 'HASH' && exists($h->{$key})) { my $val = $h->{$key}; my $x = shift; # backup $_ = $x; # copy from default wants tables. if (!ref($val) && defined($wants{$val})) { $val = $wants{$val}; } # check value types if ($_ eq '') { ; # null string is o.k. } elsif ($val eq '') { ; # o.k. } elsif (ref($val) eq 'CODE') { $_ = &{$val}($_); } elsif (defined(eval($val))) { ; # good. } else { carp $@ if $@ && $LOG > 3; # evaluation error... undef $_; } if (!defined($_)) { croak("Param ($key, $x) invalid value") if $LOG > 4; $p->{param_error}++; return undef; } } # Result is the converted value. $_; } ;# ;# sub getval ($$) { my $p = shift; my $key = shift; $p->try_check($key) || return undef; defined($p->{$key}) ? $p->{$key} : undef; } ;# ;# sub delete ($$) { my $p = shift; my $key = shift; $p->try_check($key) || return undef; exists($p->{$key}) ? CORE::delete($p->{$key}) : 0; } ;# ;# sub setval ($$$) { my $p = shift; my $key = shift; my $val = shift; my $x = $p->try_check($key, $val); defined($x) ? ($p->{$key} = $x) : undef; } ;# ;# sub addval ($$$) { my $p = shift; my $key = shift; my $val = shift; $val = $p->{$key}."\n".$val; my $x = $p->try_check($key, $val); defined($x) ? ($p->{$key} = $x) : undef; } ;# dump parameters ;# sub dump ($) { my $p = shift; print "* $p name=$p->{param_name}\n"; my @keys = sort keys %{$p}; my $key; for $key (grep(/^param_/, @keys), grep(!/^param_/, @keys)) { my $val = $p->{$key}; if ($val =~ /\n/) { my $s = $val =~ s/^\n// ? '+' : ''; print " $key $s=\n"; for $s (split(/\n/, $val)) { print " $s\n"; } } else { print " $key = $val\n"; } } 1; } ;# Combine some parameters for Param objects. ;# $p->combine($a, $b, ..., $z, $flag) will combine as follows: ;# in order of $a, $b, ..., $z, copy parameter values to $p. ;# If $flag is non zero, override is permitted. ;# sub combine ($@) { my $p = shift; # output object my @list = (); my $count = 0; my $n; # check Param objects. while (defined($n = shift) && ref($n) && $n->isa('Fan::Param')) { push(@list, $n); } # now $n is the flag of override. my $param; for $param (@list) { my $key; my $val; while (($key, $val) = each %{$param}) { next if $key =~ /^param_/; if (exists($p->{$key})) { if ($val =~ /^\n/) { # append $val = $p->{$key}.$val; } elsif (!$n) { # not override next; } } if ($p->try_check($key)) { $p->{$key} = $val; # copy $count++; } else { ; # simply ignored } } } # succeeded 1; } ;# $p->merge($a, $b, ..., $z) is same as ;# $p->combine($a, $b, ..., $z, 1); ;# sub merge ($@) { my $p = shift; $p->combine(@_, 1); } ;# Subroutines for check operations ;# sub want_ref { my $x = shift; if (@_) { ref($x) eq shift || return undef; } else { ref($x) || return undef; } $x; } ;# sub want_code { want_ref(shift, 'CODE'); } ;# sub want_hash { want_ref(shift, 'HASH'); } ;# sub want_array { want_ref(shift, 'ARRAY'); } ;# want boolean value, ;# converted to 1 or 0. ;# sub want_boolean { my $x = shift; return $& ? 1 : 0 if $x =~ /^\d+$/; return 1 if $x =~ /^(yes|t|true|do|will)$/i; return 0 if $x =~ /^(no|nil|false|dont|wont)$/i; undef; } ;# want decimal value, ;# force to be converted to an integer. ;# sub want_decimal { my $x = shift; return $& + 0 if $x =~ /^\d+$/; undef; } ;# want octal value, ;# sub want_octal { my $x = shift; return $& if $x =~ /^[0-7]+$/; undef; } ;# want an integer value (with or without sign), ;# force to be an integer. ;# sub want_integer { my $x = shift; my $flag = 1; if ($x =~ s/^-//) { $flag = -1; } elsif ($x =~ s/^\+//) { ; } return $flag * $& if $x =~ /^\d+$/; undef; } ;# want IPv4 address. ;# sub want_ipv4_addr { my $x = shift; return $& if $x =~ /^\d+\.\d+\.\d+\.\d+$/; undef; } ;# want_path($string, $eval) ;# convert a tilda notation (like ~ftp). ;# sub want_path { my $path = shift; my $dir = ''; # warn("input is \"$path\"\n"); # Expand pathname first. # For example, "~ikuo/src/hogehoge" will expanded to # "/home/ikuo/src/hogehoge". if ($path =~ s|^~([^/]*)||) { if ($1 ne '') { $dir = (getpwnam($1))[7]; } else { $dir = $ENV{'HOME'} || (getpwuid($<))[7]; } $path = $dir.$path; } # Result must not be null string. return undef if $path eq ''; # Evaluation test. if (@_) { local $_ = $path; if(!defined(eval shift)) { carp $@ if $@ && $LOG > 3; # warn("result is undef\n"); return undef; } $path = $_; } # warn("result is path\n"); # Result is $path. $path; } ;# sub want_file { want_path(shift, '-f $_ || undef'); } ;# sub want_directory { want_path(shift, '-d $_ || undef'); } ;# want timezone. ;# converted to ``sign . %02d . %02d ''. ;# sub want_timezone { my $tz = shift; if ($tz =~ /^(\+|-)(\d\d?)(\d\d)$/) { return sprintf("%s%02d%02d", $1, $2, $3); } elsif ($tz eq 'GMT') { return '+0000'; } elsif ($tz eq 'JST') { return '+0900'; } undef; } ;# end of Fan::Param module ftpmirror-1.96/Fan/Param/test.pl100644 1751 1750 2457 6401315304 15012 0ustar ikuouserBEGIN { $| = 1; print "1..4\n"; } END { print "not ok 1\n" unless $loaded; } use Fan::Param; $loaded = 1; print("ok 1\n"); $Fan::Param::LOG = 7; sub proc { local $_ = shift; /proc/i ? $_ : undef; } %pkeys = ( key_any => '', key_int => 'INTEGER', key_bool => 'BOOLEAN', key_code => 'CODE', key_hash => 'HASH', key_proc => \&proc, ); $param = Fan::Param->new( param_name => 'TEST', param_keys => \%pkeys ); ref($param) && $param->isa('Fan::Param') or print("not ok 2\n"), exit; print("ok 2\n"); $success = eval { $param->setval('key_any', 'Anything is o.k.'), 'key_any' } && eval { $param->setval('key_proc', 'PROCEDURE'), 'key_proc' } && eval { $param->setval('key_hash', \%pkeys), 'key_hash' } && eval { $param->setval('key_code', \&proc), 'key_code' } && eval { $param->setval('key_bool', 'FALSE'), 'key_bool' }; $success or print("not ok 3: $@"), exit; print("ok 3\n"); $failure = eval { $param->getval('not_a_key'), 'not_a_key' } || eval { $param->setval('key_int', 'no int'), 'key_proc' } || eval { $param->setval('key_proc', \%pkeys), 'key_proc' } || eval { $param->setval('key_hash', \&proc), 'key_hash' } || eval { $param->setval('key_code', 20), 'key_code' } || eval { $param->setval('key_bool', "must"), 'key_code' }; $failure and print("not ok 4 ($failure): $@\n"), exit; print("ok 4\n"); ftpmirror-1.96/Fan/Scan/ 40755 1751 1750 0 7031563574 13233 5ustar ikuouserftpmirror-1.96/Fan/Scan/Changes100644 1751 1750 172 6401315307 14570 0ustar ikuouserRevision history for Perl extension Fan::Scan. 0.01 Thu Aug 21 21:20:16 1997 - original version; created by h2xs 1.18 ftpmirror-1.96/Fan/Scan/MANIFEST100644 1751 1750 55 6401315310 14400 0ustar ikuouserChanges MANIFEST Makefile.PL Scan.pm test.pl ftpmirror-1.96/Fan/Scan/Makefile.PL100644 1751 1750 142 6401315310 15236 0ustar ikuouseruse ExtUtils::MakeMaker; WriteMakefile( 'NAME' => 'Fan::Scan', 'VERSION_FROM' => 'Scan.pm', ); ftpmirror-1.96/Fan/Scan/Scan.pm100644 1751 1750 67241 6607642576 14614 0ustar ikuouser;# ;# Copyright (c) 1995-1997 ;# 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: Scan.pm,v 1.21 1998/10/10 11:31:10 ikuo Exp $ ;# ;# For example, to list up all directories and files in ;# servers tree; ;# ;# use Fan::FTP; ;# use Fan::Scan; ;# ;# $ftp = Fan::FTP->new(ftp_server = 'ftp.freebsd.org'); ;# $scan = Fan::Scan->new( ;# scan_type => 'FTP', ;# scan_ftp => $ftp, ;# scan_dir => '/pub/FreeBSD' ); ;# while (defined($p = $scan->get)) { ;# last if $p->type eq '.'; ;# print $p->path."\n" if $p->type ne 'U'; ;# } ;# package Fan::Scan; use strict; use vars qw($VERSION $LOG $n_object $path_gzip $path_compress %required %typemap %typerev); use Carp; use Fan::Attrib; use AutoLoader 'AUTOLOAD'; $VERSION = '0.04'; $LOG = 5 unless defined($LOG); ;# $path_gzip = &findpath("gzip"); $path_compress = &findpath("compress"); ;# A special marker for AutoSplit. 1; __END__ ;# sub findpath ($) { my $foo = shift; my @path = split(':', $ENV{'PATH'}); # append some system specific directories... push(@path, qw( /usr/ucb /usr/ccs /usr/local/bin /usr/gnu/bin /usr/contrib/bin /opt/local/bin /opt/gnu/bin /opt/contrib/bin)); # check existence of the executable. for my $d (@path) { return "$d/$foo" if -x "$d/$foo" && ! -d _; } # return itself if executables were not found. $foo; } ;# Destroy Scan object... ;# sub DESTROY ($) { my $self = shift; # Close any files first (if we have). $self->close; # Log message. carp("Scan DESTROYING $self") if $LOG > 5; } ;# ;# search a directory information for the specified directory. ;# usage: ;# scan_type : ;# LOCAL ... scan_dir ;# INDEX ... scan_index ;# LSLR ... scan_lslR ;# FTP ... scan_ftp, scan_dir ;# HTTP ... scan_ftp, scan_dir ;# $scan = Fan::Scan->new( ;# scan_type => LSLR, ;# scan_lslR => "ls-lR.gz" ); ;# sub new ($%) { my $this = shift; my $class = ref($this) || $this; my %params = @_; my $self = {}; bless $self, $class; # copy any scan parameter. for my $tag (keys %params) { $self->{$tag} = $params{$tag} if $tag =~ /^scan_/; } # Find out scan type. my $t = $self->{scan_type}; # Check types... if (!defined($t)) { # not found. carp("No scan_type defined"), return undef; } elsif ($t eq 'LOCAL') { # scan local directory $self->{scan_dir} ne '' && -d $self->{scan_dir} or carp("No local directory"), return undef; } elsif ($t eq 'FTP') { ref($self->{scan_ftp}) # must be some module or carp("No scan_ftp"), return undef; $self->{scan_dir} ne '' or carp("No scan_dir"), return undef; } elsif ($t eq 'INDEX') { $self->open($self->{scan_index}) or carp("open(scan_index): $!"), return undef; } elsif ($t eq 'LSLR') { $self->open($self->{scan_lslR}) or carp("open(scan_lslR): $!"), return undef; } else { carp("Scan does not know method"), return undef; } # cleanup delete($self->{endoffile}); delete($self->{founderror}); delete($self->{subst}); delete($self->{hold}); $self->{magic_array} = {}; $self->{cur_info} = {}; $self->{dirs} = []; $self->{lslR_curdir} = '.'; $self->{scan_filter} = []; # Log message. carp("Scan CREATING $self") if $LOG > 5; # Return myself $self; } ;# ;# To get the current working directory, use $p->where. ;# It tells where you are. ;# sub where ($) { my $self = shift; exists($self->{walk_curdir}) ? $self->{walk_curdir} : undef; } ;# ;# $p->start initialize all variables used by `where', `up', ;# and `down'. This routine must be called before you call ;# these routines. ;# sub start ($) { my $self = shift; # DEBUG purpose only. confess("$self->{walk_curdir} exists in stack") if exists($self->{walk_curdir}); # initial current walk directory is '.'. $self->{walk_curdir} = '.'; # DEBUG mode only warn("Scan +DIR=. (start)\n") if $LOG > 7; # result is current directory $self->{walk_curdir}; } ;# ;# $p->end is useful for the aftercare and validation of ;# directory stack operations. ;# This routine should be called at last of your directory ;# stack operations. ;# sub end ($) { my $self = shift; # DEBUG purpose only. confess("$self->{walk_curdir}: remains in stack") unless ($self->{walk_curdir} eq '.'); # clean work directory entry delete($self->{walk_curdir}); # DEBUG mode only warn("Scan -DIR=. (end)\n") if $LOG > 7; # result is current directory undef; } ;# ;# You can go to DOWN stair with $p->down(you_want_to_go). ;# you_want_to_go must no contains a slash(== `/'). ;# Additionally, it must not be a null string, `.' or `..'. ;# sub down ($$) { my $self = shift; my $dir = shift; # you_want_to_go # DEBUG purpose only. confess("$dir: illegal directory name") if $dir eq '' || $dir eq '.' || $dir eq '..' || $dir =~ /\//; # go down one directory $self->{walk_curdir} .= '/'.$dir; # DEBUG mode only warn("Scan +DIR=$self->{walk_curdir}\n") if $LOG > 7; # result is current directory $self->{walk_curdir}; } ;# ;# You can go to UP stair with $p->up. ;# sub up ($) { my $self = shift; # DEBUG purpose. confess("$self->{walk_curdir}: no upper directory") unless $self->{walk_curdir} =~ s|/[^/]+$||; # DEBUG mode only. warn("Scan -DIR=$self->{walk_curdir}\n") if $LOG > 7; # result is current directory $self->{walk_curdir}; } ;# ;# Scan::open ;# Open a file, which may be .gz or .Z compressed file. ;# sub open ($$) { my $self = shift; my $file = shift; # close first $self->close; # check filter if (ref($file) ne 'GLOB') { my $a = $file =~ /\.gz$/ ? "$path_gzip -cd $file|" : $file =~ /\.Z$/ ? "$path_compress -cd $file|" : -f $file ? $file : -f "$file.gz" ? "$path_gzip -cd $file.gz|" : -f "$file.Z" ? "$path_compress -cd $file.Z|" : $file; # local file handle. local *FILE; # Now, try to open. unless (CORE::open(FILE, $a)) { carp("CORE::open($a): $!"); return undef; } # warn("open[".fileno(*FILE)."] $a: o.k.\n"); # mark as OPENED file. $self->{needclose}++; # now store to $file. $file = *FILE; } # Register the file handle $self->{handle} = $file; # Increment # of objects $n_object++; # Success 1; } ;# close file handle if needed. ;# sub close ($) { my $self = shift; if ($self->{needclose} && exists($self->{handle})) { CORE::close($self->{handle}); } $self->{needclose} = 0; delete($self->{handle}); 1; } ;# ;# Add a filter to Scan object. ;# sub add_filter ($@) { my $self = shift; my @args = @_; my $c = $args[$[]; if (ref($c) ne 'CODE') { carp("$self->add_filter: $c must be a CODE"); return undef; } push(@{$self->{scan_filter}}, \@args); } ;# ;# clear filter ;# sub clr_filter ($) { my $self = shift; $self->{scan_filter} = []; } ;# ;# sub perform_filter ($$) { my $self = shift; my $y = shift; # for DEBUG mode only. confess("$y must be Attrib") unless ref($y) && $y->isa('Fan::Attrib'); # loop over all scan_filter or finding mismatch. for my $filter (@{$self->{scan_filter}}) { my($c, @args) = @{$filter}; # for DEBUG mode only. confess("$c must be CODE") unless ref($c) eq 'CODE'; # try to perform filter... &{$c}($y, @args) || return 0; } # all filter functions return ok 1; } ;# Unget means, save current value to hold buffer. ;# Next get operation may returns this. sub unget ($$) { my $self = shift; $self->{hold} = shift; } ;# ;# sub get ($) { my $self = shift; my $y; # If there is an entry in hold buffer, we return it. delete($self->{hold}), return $y if defined($y = $self->{hold}); # Get one! # When a directory object was marked as 'IGNORED' by filter, # we should ignore any additional files in that directory. my $ignore_nest = 0; while (defined($y = $self->getone)) { warn($y->to_line."\n") if $LOG >= 8; # in full debug mode # Check if we are in an ignored directory. if ($ignore_nest > 0) { $ignore_nest-- if $y->type eq 'U'; $y->flag('!'); # and skip this entry. } # Shall we return this attrib object? if ($y->flag eq '!') { $self->{ignore_nest}++ if $y->type eq 'D'; } else { last; # } } # Check error. if (!defined($y)) { if ($self->{founderror}) { # This may be dangerous, so we should terminate # any processing. croak("Scan::get: error was detected"); } } # The result $y; } ;# ;# Get a single entry from index tree. ;# sub getone ($) { my $self = shift; my $y; # Check end-of-file or error. return undef if $self->{endofdata} || $self->{founderror}; # Check array reference. Error in next statement is critical. if (ref($self->{dirs}) ne 'ARRAY') { confess("\$self->{dirs} must be ARRAY"); } # Try to parse and store to $y. $y = $self->{scan_index} ? $self->get_index : $self->get_misc; # Check result. unless (ref($y) && $y->isa('Fan::Attrib')) { carp("getone: can't get Fan::Attrib object"); $self->{founderror}++; return undef; } # We prefer an abbrev for the type of this Attrib object. my $t = $y->type; # If last one is a directory, go down there. if (exists($self->{nextdir})) { push(@{$self->{dirs}}, $self->{nextdir}); delete($self->{nextdir}); # clean next directory entry } # We assume the first entry is the `.' directory. if (@{$self->{dirs}} == 0) { # this is the first time if (!($t eq 'D' && $y->name eq '.')) { carp("First entry must be the \".\" directory."); $self->{founderror}++; return undef; } $self->{nextdir} = '.'; # save to hold buffer return $y; } # Type '.' means END-OF-DATA. if ($t eq '.') { if (@{$self->{dirs}} == 1) { # verify o.k. pop(@{$self->{dirs}}); $self->{endofdata}++; return $y; } if (@{$self->{dirs}} > 1) { carp("remaining directories: \"" .join('/', @{$self->{dirs}})."\""); } else { carp("No directory in stack"); } $self->{founderror}++; return undef; } # Type 'U' is `Go to the up stair'. if ($t eq 'U') { # one dir up if (@{$self->{dirs}} < 2) { carp("Too many dir UP"); $self->{founderror}++; return undef; } $y->name(pop(@{$self->{dirs}})); # not return yet } # Remaining cases require `name' attribute. Check it. my $n = $y->name; if (!defined($n)) { confess("$y: no name found."); } elsif ($n =~ m%[\001\377]%) { confess("$y: name contains illegal charactor."); } elsif ($n =~ m%/([^/]+)$%) { # contains slash(es) confess("$y: name contains slash(es)."); } elsif ($n eq '.' || $n eq '..') { confess("$y: \"$n\" is invalid."); } else { ; # o.k. } # DEBUG mode only. # Calculate pathname from directory array. my $path = join('/', @{$self->{dirs}}, $n); confess($y->path." != $path") unless $y->path eq $path; # Type 'U' was already processed. if ($t eq 'U') { return $y; } # Type 'D' is a directory. Copy to the nextdir hold buffer. if ($t eq 'D') { $self->{nextdir} = $n; return $y; } # Type 'L' is a symlink. if ($t eq 'L') { # symlink if (!defined($y->linkto)) { # linkto is required carp("$y: no linkto for symlink"); $self->{founderror}++; return undef; } return $y; } # Type 'F' is a normal file. if ($t eq 'F') { # normal file return $y; } # Or, unknown type is specified. carp("$t: illegal type"); return undef; } ;# sub get_index ($) { my $self = shift; my $fh = $self->{handle}; # Check end-of-file or error. return undef if $self->{endofdata} || $self->{founderror}; # DEBUG mode only. confess("\$fh must be defined") unless defined($fh); # Try to read from the file handle. local $_; while (defined($_ = <$fh>)) { # skip trailing spaces, and ignore comment lines. s/\s+$//; /^$/ || /^#/ || last; warn("READ($.): $_\n"); } # Check end-of-file. if (!defined($_)) { carp("file [".fileno($fh)."] unexpected END-OF-FILE at $."); $self->{founderror}++; return undef; } # Let's parse it. my $y = Fan::Attrib->new(attr_line => $_); # Check result. ref($y) && $y->isa('Fan::Attrib') or carp("Can't create Attrib from $_"), return undef; # where am I? my $d; if (!defined($d = $self->where)) { $y->path('.'); $self->start; } else { if ($y->type eq '.') { $self->end; } elsif ($y->type eq 'U') { $y->path($d); $self->up; } else { $y->path($d.'/'.$y->name); if ($y->type eq 'D') { $self->down($y->name); } } } # try filter $y->flag('!') unless $self->perform_filter($y); # result is Attrib or undef. $y; } ;# ;# Scan with directory structure. ;# We should get directory entries per directory, sort them, ;# and hold until they will be used. A special reference of ;# $self->{magic_array} is used to hold directory entires. ;# sub get_misc ($) { my $self = shift; my $y; # Try to get the current working directory... my $dir; if (!defined($dir = $self->where)) { $self->start; $y = $self->{scan_type} eq 'LOCAL' ? Fan::Attrib->new(attr_path => "$self->{scan_dir}/.") : Fan::Attrib->new(y_type => 'D', y_name => '.'); if (defined($y)) { $y->path('.'); $y->flag('!') unless $self->perform_filter($y); } else { carp("Attrib: Can't create object"); } return $y; } # Delete skipped directories. my $cur = $dir; my $cur_n = ($cur =~ y|/|\001|); my $d; for $d (keys %{$self->{magic_array}}) { my $tmp = $d; my $tmp_n = ($tmp =~ y|/|\001|); if ($tmp_n >= $cur_n && $tmp lt $cur) { warn("Scan: ($d lt $dir) is true... skipped.\n") if $LOG > 5; delete($self->{magic_array}->{$d}); } } # Check magic_array first. my $p = $self->{magic_array}->{$dir}; # Try to get magic array for this directory if (!defined($p)) { $p = $self->{scan_type} eq 'LOCAL' ? $self->dir_local($dir) : $self->{scan_type} eq 'LSLR' ? $self->dir_lslR($dir) : $self->{scan_type} eq 'FTP' ? $self->dir_ftp($dir) : undef; unless (defined($p)) { carp("get_misc: can't get array"); return undef; } } # Now, ($p == $self->{magic_array}->{$dir}) is true. if (defined($y = shift(@{$p}))) { # something remains $y->path($dir.'/'.$y->name); if ($y->type eq 'D') { $self->down($y->name); } unless ($self->perform_filter($y)) { $y->flag('!'); if ($y->type eq 'D') { # setup dummy array $self->{magic_array}->{$self->where} = []; } } } else { # or terminate this directory delete($self->{magic_array}->{$dir}); # clean if ($dir eq '.') { $self->end; $y = Fan::Attrib->new(y_type => '.'); } else { my $tail = $dir =~ m|([^/]+)$| ? $1 : '.'; $self->up; $y = Fan::Attrib->new( y_type => 'U', y_name => $tail, y_path => $dir ); } if (defined($y)) { $y->flag('!') unless $self->perform_filter($y); } else { confess("Attrib: Can't create object") } } # return Attrib object. $y; } ;# ;# Usage: ;# array_ref = $scan->dir_local(directory); ;# sub dir_local ($$) { my $self = shift; my $dir = shift; my $d = "$self->{scan_dir}/$dir"; my $p = []; local(*D); opendir(D, $d) or carp("opendir($d): $!"), return undef; my @entry = readdir(D); closedir(D); # for all entries my $e; for $e (sort @entry) { next if $e eq '' || $e eq '.' || $e eq '..'; my $x = Fan::Attrib->new( attr_path => "$d/$e", attr_no_checksum => $self->{scan_no_checksum} ); if (defined($x)) { # $x->realpath("$d/$e"); push(@{$p}, $x); } } # return a reference to array. $self->{magic_array}->{$dir} = $p; } ;# ;# Usage: ;# array_ref = $scan->dir_ftp(directory); ;# sub dir_ftp ($$) { my $self = shift; my $dir = shift; my $d = "$self->{scan_dir}/$dir"; my $ftp = $self->{scan_ftp}; my $hash = undef; # try to get magic array for this directory if ($self->{scan_dirinfo}) { use Fan::DIR; my $tmp = "/tmp/dirinfo.$$"; my $info = Fan::DIR->new(); if ($ftp->get("$d/.dirinfo", $tmp) && $info->load($tmp)) { my $f; for $f ($info->index) { $hash->{$f} = $info->get($f); } } elsif ($ftp->fatal) { carp("Scan: can't get dirinfo, fatal") if $LOG > 5; return undef; } else { carp("Scan: can't get dirinfo, try nest") if $LOG > 5; } unlink($tmp); } # no scan_dirinfo, or fail to load dirinfo. if (!defined($hash)) { local $_ = $ftp->list($d); unless (defined($_)) { warn("Scan: can't get list of $d\n") if $LOG > 5; return undef; } $hash = {}; my $x; for $x (split(/\n/)) { my $y; if (!defined($y = Fan::Attrib->new(attr_list => $x))) { warn("$x: could not parse, ignored.\n") if $LOG > 6; } else { $hash->{$y->name} = $y; } } } my $x; my $p = []; for $x (sort keys %{$hash}) { if ($x ne '' && $x ne '.' && $x ne '..') { $hash->{$x}->realpath("$d/$x"); push(@{$p}, $hash->{$x}); } } $self->{magic_array}->{$dir} = $p; } ;# ;# Usage: ;# array_ref = $scan->dir_lslR(directory); ;# sub dir_lslR ($$) { my $self = shift; my $dir = shift; my $p; while (!defined($p = $self->{magic_array}->{$dir})) { $self->getline_lslR || return undef; } $p; } ;# ;# read a line from ls-lR format file, and parse it. ;# if full entries for a directory $d was found, ;# you can access directory info for that directory from ;# $self->{magic_array}->{$d}. ;# sub getline_lslR ($){ my $self = shift; my $fh = $self->{handle}; local $_; # check previouse error or end-of-file return undef if $self->{endoffile} || $self->{founderror}; # validate file handle confess("Can't find file handle") unless defined($fh); # y structure, separator my $delim = 0; # read a line if (!(defined($_ = <$fh>))) { $self->{endoffile}++, $delim++; } elsif (/^$/) { # null line $delim++; # end-of-directory } elsif (/^total (\d+)/) { # maybe start of a directory. # we simply ignore this. } elsif (/^.[-r][-w][-xsS][-r][-w][-xsS][-r][-w][-xtT]\s*/) { # normal entry - check this format before directory pattern # tested in next statement, because we hate a filename which # ends with ':'. my $y; if (!defined($y = Fan::Attrib->new(attr_list => $_))) { warn("$_: could not parse, ignored\n") if $LOG >= 7; } else { my $n = $y->name; if ($n ne '' && $n ne '.' && $n ne '..') { $self->{cur_info}->{$n} = $y; # registered. } } } elsif (/:$/) { # new directory my $d = $`; if (!defined($self->{subst})) { my $s = quotemeta($d =~ m%[^/]+$% ? $` : ''); $self->{subst} = sub { local($_) = @_; s|^$s|./|; $_; }; } $self->{lslR_curdir} = &{$self->{subst}}($d); } else { # other case? warn("$_ unknown format, ignored\n") if $LOG >= 7; $self->{founderror}++; return undef; } # directory delimiter if ($delim) { my $d = $self->{lslR_curdir}; delete($self->{lslR_curdir}); my $p = $self->{cur_info}; $self->{cur_info} = {}; my $q = $self->{magic_array}->{$d} = []; ### DEBUG BEGIN (for debug only) if ($d ne '.' && $d !~ /^\.\//) { confess("directory name must begin with '.'\n"); } ### DEBUG END my $n; for $n (sort keys %{$p}) { push(@{$q}, $p->{$n}); } } # success return 1; } ;# ;# sub dump ($) { my $self = shift; my $count = 0; my $d; for $d (sort keys %{$self->{magic_array}}) { my $p = $self->{magic_array}->{$d}; my $y; for $y (@{$p}) { print "dump: ".$y->path."\n"; } $count += @{$p}; } print "dump: total $count entries.\n"; } ;# ;# sub summary ($) { my $self = shift; my $count = 0; my $d; for $d (sort keys %{$self->{magic_array}}) { $count += scalar(@{$self->{magic_array}->{$d}}); } print "summary: total $count entries.\n"; } ;# ;# Get an array of ``smallest'' attributes from ;# a list of Scan objects. ;# sub getcmp ($@) { my @array = @_; my $end = 0; my $z = undef; # the smallest attribute my $pp; # Search smallest entry, first for $pp (@array) { my $p; if (defined($p = $pp->get)) { $pp->unget($p); $z = $p if !defined($z) || $p->compare($z) < 0; } else { $end++; } } # Check end-of-data if ($end == @array) { return wantarray ? () : undef; } elsif ($end > 0) { confess("Some unexpected case occured"); } # OK, $z is the smallest one, try to generate result. my @result = (); # Get an item if smallest values can be found. for $pp (@array) { my $p = $pp->get; if ($z->compare($p)) { $pp->unget($p); push(@result, undef); } else { push(@result, $p); } } # Result is an list of attributes. @result; } ;# guessing..., return the Scan object. ;# sub guess ($$) { my $this = shift; my $foo = shift; # if we already have scanner, return it. return $foo if ref($foo) && $foo->isa('Fan::Scan'); # directory? if (-d $foo) { return $this->new(scan_type => 'LOCAL', scan_dir => $foo); } # regular file? if so, it must be an index file. if (-f $foo) { return $this->new(scan_type => 'INDEX', scan_index => $foo); } # file glob? if (ref($foo) eq 'GLOB') { return $this->new(scan_type => 'INDEX', scan_index => $foo); } # file handle? if (defined(fileno($foo))) { return $this->new(scan_type => 'INDEX', scan_index => \*{$foo}); } # what is this? undef; } ;# convert file name to a file glob. ;# sub fileglob ($;$) { my $file = shift; my $m = @_ ? shift : ''; # mode... # do nothing if $file is a file glob. return $file if ref($file) eq 'GLOB'; # check modes. $m = '<' if $m eq 'r'; $m = '>' if $m eq 'w'; $m = '>>' if $m eq 'a'; # check modes... unless ($m eq '' || $m eq '<' || $m eq '>' || $m eq '>>') { carp("fileglob: wrong mode to open operation") if $LOG >= 5; return undef; } # check special filename. if ($file eq '' || $file eq '-') { if ($m eq '' || $m eq '<') { return \*STDIN; } else { return \*STDOUT; } } # try to open the target file. local *TEMP; unless (CORE::open(TEMP, $m.$file)) { carp("fileglob: open($m.$file): $!") if $LOG >= 5; return undef; } # debug log... warn("fileglob: open[".fileno(*TEMP)."] $file: o.k.\n") if $LOG > 5; # result *TEMP; } ;# ;# scan_mklist(output, directory); ;# ;# Return codes: ;# undef error was detected. ;# 1 success, the newest list was created. ;# sub scan_mklist ($$) { my $file = shift; my $dir = shift; my $op = &fileglob($file, 'w'); my $no = fileno($op); if (!defined($no)) { carp("scan_mklist: fileglog($file): failure.") if $LOG > 5; return undef; } # debug log if (ref($op) eq 'GLOB') { # normal file. warn("scan_mklist: use[$no] $file: o.k.\n") if $LOG > 5; } else { warn("scan_mklist: open[$no] $file: o.k.\n") if $LOG > 5; } # Try to open local directory tree. my $scan = Fan::Scan->guess($dir); unless (ref($scan) && $scan->isa('Fan::Scan')) { carp("scan_mklist: can't create scanner($dir)"); return undef; } # generate lists. my $a; while (defined($a = $scan->get)) { $a->fill_checksum; # checksum is optional. print $op $a->to_line."\n"; } # close if needed. if (ref($op) eq 'GLOB') { warn("scan_mklist: unuse[$no] $file...\n") if $LOG > 5; } else { warn("scan_mklist: close[$no] $file...\n") if $LOG > 5; } # this causes the target file be closed automatically. undef $op; # success. 1; } ;# ;# Generate diffs for given two index files. ;# scan_mkdiff(output, old, new) ;# ;# Return codes: ;# undef error was detected. ;# 0 diff file was generated, but no change exists. ;# other # of changes. diff file was generated. ;# sub scan_mkdiff ($$$) { my $file = shift; my $old = shift; my $new = shift; my $op = &fileglob($file, 'w'); my $no = fileno($op); if (!defined($no)) { carp("scan_mkdiff: fileglog($file): failure.") if $LOG > 5; return undef; } # debug log if (ref($op) eq 'GLOB') { # normal file. warn("scan_mkdiff: use[$no] $file: o.k.\n") if $LOG > 5; } else { warn("scan_mkdiff: open[$no] $file: o.k.\n") if $LOG > 5; } my $oldscan = Fan::Scan->guess($old); unless(ref($oldscan) && $oldscan->isa('Fan::Scan')) { carp("scan_mkdiff: can't create scanner($old)"); return undef; } my $newscan = Fan::Scan->guess($new); unless(ref($newscan) && $newscan->isa('Fan::Scan')) { carp("scan_mkdiff: can't create scanner($new)"); return undef; } my @dir = (); # directry stack my $modify = 0; # modification flag my $a; my $b; while (($a, $b) = $oldscan->getcmp($newscan)) { # check difference first. if (!defined($a) && !defined($b)) { confess("scan_mkdiff: UNEXPECTED CASE"); } elsif (!defined($a)) { $b->flag('+'); } elsif (!defined($b)) { $b = $a; $b->flag('-'); } elsif (attr_cmp($a, $b)) { # differs $b->flag('+'); } else { $b->flag(''); } # print difference if required. if ($b->type eq '.') { print $op ".\n"; # END-OF-DATA. } elsif ($b->type eq 'D' && $b->name eq '.') { print $op $b->to_line."\n"; } elsif ($b->flag ne '') { while (@dir) { print $op shift(@dir)->to_line."\n"; } print $op $b->to_line."\n"; $modify++; } elsif ($b->type eq 'D') { push(@dir, $b); } elsif ($b->type eq 'U') { if (@dir) { pop(@dir); } else { print $op "U\n"; } } else { # (flag == '' && type !~ /[DU.]/) ; # ignored } } # close if needed. if (ref($op) eq 'GLOB') { warn("scan_mkdiff: unuse[$no] $file...\n") if $LOG > 5; } else { warn("scan_mkdiff: close[$no] $file...\n") if $LOG > 5; } # this causes the target file be closed automatically. undef $op; # return # of differences. $modify; } ;# ;# scan_update(output, base, diff [, diff...]); ;# ;# Return codes: ;# undef error was detected. ;# 1 success, the newest list was created. ;# sub scan_update ($$@) { my $file = shift; my $base = shift; my @diff = @_; my $op = &fileglob($file, 'w'); my $no = fileno($op); if (!defined($no)) { carp("scan_update: fileglog($file): failure.") if $LOG > 5; return undef; } # debug log if (ref($op) eq 'GLOB') { # normal file. warn("scan_update: use[$no] $file: o.k.\n") if $LOG > 5; } else { warn("scan_update: open[$no] $file: o.k.\n") if $LOG > 5; } # Open the index who has maximum number. my $basescan = Fan::Scan->guess($base); unless(ref($basescan) && $basescan->isa('Fan::Scan')) { carp("update: can't create scanner($base)"); return undef; } warn("scan_update: base $base: o.k.\n") if $LOG > 5; # Initialize array. my @array = (); # Open step files... for my $file (@diff) { my $q = Fan::Scan->guess($file); unless(ref($q) && $q->isa('Fan::Scan')) { carp("update: can't create scanner($file)"); return undef; } push(@array, $q); warn("scan_update: add $file: o.k.\n") if $LOG > 5; } # Try merge my @a; while (@a = $basescan->getcmp(@array)) { my $a; my $x = undef; while (@a) { my $a = shift(@a); $x = $a if ref($a) && $a->isa('Fan::Attrib'); } if (!defined($x)) { confess("scan_update: UNEXPECTED CASE"); } elsif ($x->flag ne '-') { $x->flag(''); print $op $x->to_line."\n"; } } # close if needed. if (ref($op) eq 'GLOB') { warn("scan_update: unuse[$no] $file...\n") if $LOG > 5; } else { warn("scan_update: close[$no] $file...\n") if $LOG > 5; } # this causes the target file be closed automatically. undef $op; # Success return. 1; } ;# Compare two Attrib objects. ;# sub attr_cmp ($$) { my $a = shift; my $b = shift; my $tag; my $val; # check each items... while (($tag, $val) = each %{$a}) { next if $tag !~ /^y_/; return -1 if $b->{$tag} ne $val; } # or same 0; } ;# end of Fan::Scan module ftpmirror-1.96/Fan/Scan/test.pl100644 1751 1750 3164 6406110340 14630 0ustar ikuouserBEGIN { $| = 1; print "1..8\n"; %tempfiles = (); } END { print("not ok 1\n") unless $loaded; for my $f (keys %tempfiles) { warn("unlink($f)...\n"), unlink($f) if -e $f; } } use Fan::Scan; $loaded = 1; print("ok 1\n"); $tmp1 = "tmp$$.1"; $tempfiles{$tmp1}++; $tmp2 = "tmp$$.2"; $tempfiles{$tmp2}++; $Fan::Scan::LOG = 6; $scan = Fan::Scan->new( scan_type => 'LOCAL', scan_dir => '../.', ); ref($scan) && $scan->isa('Fan::Scan') or print("not ok 2\n"), exit(1); print("ok 2\n"); $scan->add_filter(\&filter, $tmp1, $tmp2) or print("not ok 3\n"), exit(1); print("ok 3\n"); $fh = Fan::Scan::fileglob($tmp1, 'w'); defined(fileno($fh)) or print("not ok 4\n"), exit(1); print("ok 4\n"); while (defined($a = $scan->get)) { $a->fill_checksum; print $fh $a->to_line."\n"; } undef $a; undef $fh; # this cause closing $tmp1. undef $scan; $scan = Fan::Scan->guess('..'), ref($scan) && $scan->isa('Fan::Scan') or print("not ok 5\n"), exit(1); print("ok 5\n"); $scan->add_filter(\&filter, $tmp1, $tmp2) or print("not ok 6\n"), exit(1); print("ok 6\n"); Fan::Scan::scan_mklist($tmp2, $scan) or print("not ok 7\n"); print("ok 7\n"); $f1 = &Fan::Scan::fileglob($tmp1); defined(fileno($f1)) or die("fileglob: $!"); $f2 = &Fan::Scan::fileglob($tmp2); defined(fileno($f2)) or die("fileglob: $!"); system 'diff', $tmp1, $tmp2; while (1) { my $a = <$f1>; my $b = <$f2>; last if !defined($a) && !defined($b); defined($a) && defined($b) && !($a cmp $b) or print("not ok 8\n"), exit(1); } print("ok 8\n"); sub filter { my $a = shift; if ($a->type eq 'F') { $n = $a->name; for my $bad (@_) { return undef if $bad eq $n; } } 1; } ftpmirror-1.96/Fan/TCP/ 40755 1751 1750 0 7031563575 12776 5ustar ikuouserftpmirror-1.96/Fan/TCP/Changes100644 1751 1750 171 6401315312 14325 0ustar ikuouserRevision history for Perl extension Fan::TCP. 0.01 Thu Aug 21 21:52:22 1997 - original version; created by h2xs 1.18 ftpmirror-1.96/Fan/TCP/MANIFEST100644 1751 1750 54 6401315313 14144 0ustar ikuouserChanges MANIFEST Makefile.PL TCP.pm test.pl ftpmirror-1.96/Fan/TCP/Makefile.PL100644 1751 1750 140 6401315313 15001 0ustar ikuouseruse ExtUtils::MakeMaker; WriteMakefile( 'NAME' => 'Fan::TCP', 'VERSION_FROM' => 'TCP.pm', ); ftpmirror-1.96/Fan/TCP/TCP.pm100644 1751 1750 41325 6600625753 14102 0ustar ikuouser;# ;# 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: TCP.pm,v 1.20 1998/09/19 03:58:35 ikuo Exp $ ;# ;# Description: ;# TCP.pm - TCP Class definitions ;# - Socket based operations. ;# - Multiple addresses for a single server are supported. ;# package Fan::TCP; use strict; use vars qw($VERSION $LOG $tcp_proto $seq_id $sent_octets $recv_octets); use Carp; use Socket; use AutoLoader 'AUTOLOAD'; $VERSION = '0.03'; $tcp_proto = (getprotobyname('tcp'))[2]; ;# BEGIN { $LOG = 5; $seq_id = 0; $sent_octets = 0; $recv_octets = 0; } ;# status report... END { &status_report if $LOG >= 6; } ;# A special marker for AutoSplit. 1; __END__ ;# Show statistics report... sub status_report ($) { my $this = shift; my $s = $sent_octets + 0; my $r = $recv_octets + 0; 1 while $s =~ s/(\d+)(\d\d\d)/$1,$2/; 1 while $r =~ s/(\d+)(\d\d\d)/$1,$2/; my $len = 0; $len = length($s) if $len < length($s); $len = length($r) if $len < length($r); warn("TCP status summary report:\n"); warn(" total $seq_id objects created\n"); warn(" sent". '.' x ($len + 3 - length($s)) . "$s octets\n"); warn(" recv". '.' x ($len + 3 - length($r)) . "$r octets\n"); } ;# Constants - a very simple routine sub FATAL () { 0x5555; # magic number... } ;# Destroy a TCP object. sub DESTROY ($) { my $self = shift; # close and leave socket information $self->close; # count up... $sent_octets += $self->{tcp_sent_octets}; $recv_octets += $self->{tcp_recv_octets}; carp("TCP DESTROYING $self") if $LOG > 5; } ;# Creat a new TCP object. ;# ;# tcp_bindaddr => undef ;# tcp_port => undef ;# tcp_host => undef ;# tcp_timeout => 120 ;# sub new ($%) { my $this = shift; my $class = ref($this) || $this; my %params = @_; my $self = \%params; # setup default values... $self->{tcp_timeout} = 120 if !defined($self->{tcp_timeout}); $self->{tcp_state} = 1; # initial status is OK $self->{tcp_error} = ''; # error message will be stored. $self->{tcp_sent_octets} = 0; $self->{tcp_recv_octets} = 0; # bless me. bless $self, $class or return undef; # count up sequence # $seq_id++; # log message carp("TCP CREATING $self") if $LOG > 5; # return myself. return $self; } ;# Show statistics report... sub stats ($) { my $self = shift; my $s = $self->{tcp_sent_octets} + 0; my $r = $self->{tcp_recv_octets} + 0; 1 while $s =~ s/(\d+)(\d\d\d)/$1,$2/; 1 while $r =~ s/(\d+)(\d\d\d)/$1,$2/; my $len = 0; $len = length($s) if $len < length($s); $len = length($r) if $len < length($r); warn("$self status report:\n"); warn(" sent". '.' x ($len + 3 - length($s)) . "$s octets\n"); warn(" recv". '.' x ($len + 3 - length($r)) . "$r octets\n"); } ;# $tcp->clearerror trys clear error flag, or ;# $tcp->clearerror(1) force to clear error flag. ;# sub clearerror ($;$) { my $self = shift; my $force = @_ && shift(@_) ? 1 : 0; return undef if !$force && !defined($self->{tcp_state}); $self->{tcp_state} = 1; # status is o.k. $self->{tcp_error} = ''; # no error message 1; } ;# TCP object's error message at the last operation. ;# sub error ($;$$) { my $self = shift; if (@_) { $self->{tcp_error} = shift; $self->{tcp_state} = @_ && (shift == &FATAL) ? undef : 0; } $self->{tcp_error}; } ;# Returns 1 if this TCP object has fatal error status. sub fatal ($) { my $self = shift; if (@_) { my $force = shift; $self->{tcp_state} = undef if $force; } defined($self->{tcp_state}) ? 0 : 1; } ;# refer or change current status of an object. ;# status may have OK, ERROR, FATAL. sub status ($;$) { my $self = shift; # once status was undefined, you can't clear it. return undef if !defined($self->{tcp_state}); # `change status' or `refer status' ? $self->{tcp_state} = shift if @_; # result is the current status. $self->{tcp_state}; } ;# dump all key/val pairs. ;# for debug purpose only. sub dump ($@) { my $self = shift; my @index = @_ ? @_ : sort keys %{$self}; my $count = 0; print("TCP dump $self"); for my $key (@index) { if (exists($self->{$key})) { print(" $key => $self->{$key}\n"); $count++; } } $count; } ;# Send a line with CR/LF. sub putln ($$) { my $self = shift; my $sock = $self->handle; my $line = shift; my $ok = 0; # DEBUG only - check socket! defined($sock) or confess("TCP: socket is not defined"); # try to clear current status. $self->clearerror || return undef; # remove trailing spaces. DO NOT in this version. # $line =~ s/\s+$//; # print a line with CR/LF. eval { local $SIG{'ALRM'} = sub { die("alarm\n") }; alarm($self->{tcp_timeout}); $ok = print $sock ($line."\r\n"); alarm(0); }; # check result. if ($@) { if ($@ eq "alarm\n") { warn("putln: TIME OUT\n") if $LOG > 5; $self->error("operation timed out", &FATAL); return undef; } croak($@); # other evaluation error } # check result. unless ($ok) { my $e = $!.''; return $self->error($e, &FATAL); warn("TCP putln($line): $e\n") if $LOG > 6; carp("$self: print - $e"); return undef; } # debug log if ($LOG > 6 || $self->{tcp_debug}) { my $fno = fileno($self->{tcp_sock}); warn("$self [$fno] putln: $line\n"); } # count up sent data size $self->{tcp_sent_octets} += length($line) + 2; # success to put lines. 1; } ;# recieve one line respone from server. sub getln ($) { my $self = shift; my $sock = $self->handle; my $line = undef; # DEBUG only - check socket! defined($sock) or confess("TCP: socket is not defined"); # try to clear current status. $self->clearerror || return undef; # if we already found end-of-file, return undef return undef if $self->{endoffile}; # get a line from socket eval { local $SIG{'ALRM'} = sub { die("alarm\n") }; alarm($self->{tcp_timeout}); $line = <$sock>; alarm(0); }; # check result. if ($@) { if ($@ eq "alarm\n") { warn("getln: TIME OUT\n") if $LOG > 5; $self->error("operation timed out", &FATAL); return undef; } carp($@); # other evaluation error } # check result unless (defined($line)) { # this is not an error warn("TCP getln: END-OF-FILE detected.\n") if $LOG > 6; $self->{endoffile}++, return undef; } # or success to read a line chomp($line); $line =~ s/\r?$//; # debug log if ($LOG > 6 || $self->{tcp_debug}) { my $fno = fileno($self->{tcp_sock}); warn("$self [$fno] getln: $line\n"); } # count up sent data size $self->{tcp_recv_octets} += length($line) + 2; # success, and return this line. $line; } ;# send data to server sub putdata ($$) { my $self = shift; my $data = shift; my $length = length($data); my $sock = $self->handle; my $ok = undef; # DEBUG only - check socket! defined($sock) or confess("TCP: socket is not defined"); # try to clear current status. $self->clearerror || return undef; # if we already found end-of-file, return undef return undef if $self->{endoffile}; # get a line from socket eval { local $SIG{'ALRM'} = sub { die("alarm\n") }; alarm($self->{tcp_timeout}); $ok = print $sock ($data); alarm(0); }; # check result. if ($@) { if ($@ eq "alarm\n") { warn("putdata: TIME OUT\n") if $LOG > 5; $self->error("operation timed out", &FATAL); return undef; } croak($@); # other evaluation error } # check result unless ($ok) { my $e = $!.''; $self->error($e, &FATAL); carp("$self: print - $e"); return undef; } # or success to send data if ($LOG > 6 || $self->{tcp_debug}) { my $fno = fileno($self->{tcp_sock}); warn("$self [$fno] wrote $length octets.\n"); } # count up sent data size $self->{tcp_sent_octets} += $length; # success, and return this line. 1; } ;# recv data to server sub getdata ($$) { my $self = shift; my $length = shift; my $sock = $self->handle; my $data = ''; my $len = 0; my $ok = undef; # DEBUG only - check socket! defined($sock) or confess("TCP: socket is not defined"); # try to clear current status. $self->clearerror || return undef; # get a line from socket eval { local $SIG{'ALRM'} = sub { die("alarm\n") }; alarm($self->{tcp_timeout}); $len = read($sock, $data, $length); alarm(0); }; # check result. if ($@) { if ($@ eq "alarm\n") { warn("getdata: TIME OUT\n") if $LOG > 5; $self->error("operation timed out", &FATAL); return undef; } croak($@); # other evaluation error } # check result unless (defined($len) && $len > 0) { $self->{endoffile}++, return undef; } # or success to recv data if ($LOG > 6 || $self->{tcp_debug}) { my $fno = fileno($self->{tcp_sock}); warn("$self [$fno] read $len octets.\n"); } # count up sent data size $self->{tcp_recv_octets} += $len; # success, and return this line. $data; } ;# sub nowait ($) { my $self = shift; my $sock = $self->handle; defined($sock) || return undef; my $a = select($sock); $| = 1; select($a); 1; } ;# opening socket... ;# and if bindport / bindaddr was specified, we try to ;# bind the socket. ;# this should be a internal routine. sub open_socket ($%) { my $self = shift; my %params = @_; # try clear error first. $self->clearerror || return undef; # if we already have a socket, close it first. $self->close; # check local side port #. my $port = $params{tcp_bindport} || $self->{tcp_bindport} || 0; if ($port !~ /^\d+$/) { if (!defined($port = getservbyname($port, 'tcp'))) { my $e = $!.''; $self->error($e, &FATAL); carp("$self: getservbyname($port) - $e"); return undef; } } # define local side address if bindaddr is not null string. my $addr = inet_aton( $params{tcp_bindaddr} || $self->{tcp_bindaddr} || '0.0.0.0'); # parameter for bind. my $me = sockaddr_in($port, $addr); # local file handle... local *SOCKET; # creating a stream socket. unless (socket(SOCKET, PF_INET, SOCK_STREAM, $tcp_proto)) { my $e = $!.''; $self->error($e, &FATAL); carp("$self: socket - $e") if $LOG >= 5; return undef; } # bind addresses. unless (bind(SOCKET, $me)) { my $e = $!.''; $self->close; $self->error($e, &FATAL); carp("$self: bind - $e") if $LOG >= 5; return undef; } # debug log... if ($LOG > 5 || $self->{tcp_debug}) { warn("$self [".fileno(SOCKET)."] was opened.\n"); } # save it $self->{tcp_sock} = *SOCKET; # success to create and bind socket. *SOCKET; } ;# connecting the server. sub do_client ($%) { my $self = shift; my %params = @_; my $sock; # close handle if exists $self->close; # clear error or return $self->clearerror(1); # parse argument my $port = $params{tcp_port} || $self->{tcp_port}; my $host = $params{tcp_host} || $self->{tcp_host}; # check required parameters if ($port eq '') { $self->error("no tcp_port", &FATAL); carp("$self: tcp_port not defined"); return undef; } if ($host eq '') { $self->error("no tcp_host", &FATAL); carp("$self: tcp_host not defined"); return undef; } # try to parse port number if ($port !~ /^\d+$/) { if (!defined($port = getservbyname($port, 'tcp'))) { my $e = $!.''; $self->error($e, &FATAL); carp("$self: getservbyname($port) - $e"); return undef; } } # check server name my @addr; if ($host =~ /^(\d+)\.(\d+)\.(\d+).(\d+)$/) { @addr = (pack('C4', $1, $2, $3, $4)); } else { if ((@addr = gethostbyname($host)) < 5) { carp("$self: gethostbyname - $?"); my $e = $?.''; $self->error($e, &FATAL); carp("$self: gethostbyname - $e"); return undef; } splice(@addr, 0, 4); } # Perl's bug? once connect fails, we could not any more # connect (connect returns "Invalid Argument"). So we # create/close a socket in each iteration. for my $i (@addr) { # open socket stores any error $self->open_socket(%params) || return undef; # target address. my $peer = sockaddr_in($port, $i); my $result = undef; # do real work. eval { local $SIG{'ALRM'} = sub { die("alarm\n") }; alarm($self->{tcp_timeout}); $result = connect($self->{tcp_sock}, $peer); alarm(0); }; # check result. if ($result) { $self->nowait; # let this socket non-blocking warn("$self connect ok, local=" .$self->sockname.", remote=".$self->peername."\n") if $LOG > 5 || $self->{tcp_debug}; return 1; # success } if ($@) { if ($@ ne "alarm\n") { croak($@); # other evaluation error } warn("do_client: TIME OUT\n") if $LOG > 5; $self->error("operation timed out"); # not fatal. } else { # this is not a critical error, yet. my $e = $!.''; $self->error($e); carp("$self: connect - $e") if $LOG >= 6; } # perhaps, this is a perl's bug... $self->close; # or error found. } # or all connect were failed. # carp("all connect sessions were failed"); $self->error($self->error, &FATAL); undef; } ;# ;# open accept socket, and listen at specified addr/port. ;# sub do_server ($%) { my $self = shift; my %param = @_; # close handle if exists $self->close; # clear error first $self->clearerror(1); # default backlog is 5. my $backlog = $param{tcp_backlog} > 0 ? $param{tcp_backlog} : 5; # opening new socket. $self->open_socket(%param) || return undef; # try real work unless (listen($self->{tcp_sock}, $backlog)) { my $e = $!.''; $self->error($e, &FATAL); carp("$self: listen - $e"); return undef; } # success to listen 1; } ;# ;# Accept a new connection at listening socket, ;# and create a new TCP object. ;# sub new_client ($) { my $self = shift; my $sock; defined($sock = $self->handle) || return undef; my $client = $self->new; # client = new TCP object. my $result = 0; local *SOCKET; eval { local $SIG{'ALRM'} = sub { die("alarm\n") }; alarm($self->{tcp_timeout}); $result = accept(SOCKET, $sock); alarm(0); }; # check result. if ($@) { if ($@ eq "alarm\n") { warn("new_client: TIME OUT\n") if $LOG > 5; $self->error("operation timed out", &FATAL); return undef; } croak($@); # other evaluation error } # result of accept unless ($result) { my $e = $!.''; $self->error($e, &FATAL); carp("accept: $e"); return undef; } # store... $client->{tcp_sock} = *SOCKET; # debug log... if ($LOG > 5 || $self->{tcp_debug}) { my $fno = fileno($client->{tcp_sock}); warn("$self [$fno] was accepted.\n"); } # set no wait $client->nowait; $client; } ;# sub close ($) { my $self = shift; my $sock = $self->handle; # close socket if already we have opened. if (defined($sock)) { my $fno = fileno($sock); shutdown($sock, 2); CORE::close($sock); # debug log... if ($LOG > 5 || $self->{tcp_debug}) { warn("$self [$fno] was closed.\n"); } } # delete socket file handle delete($self->{tcp_sock}); # 1; } ;# sub handle ($) { my $self = shift; # check existence of tcp_sock - we must have this. unless (exists($self->{tcp_sock})) { carp("$self has no tcp_sock") if $LOG > 6; return undef; } # copy to a local variable. my $s = $self->{tcp_sock}; # validate our socket. unless (defined($s) && defined(fileno($s))) { carp("$self->tcp_sock is not a file handle") if $LOG > 7; return undef; } # DEBUG information. if ($LOG > 7) { my $fno = fileno($s); warn("$self->tcp_sock=[$fno]\n"); } # return file handle itself. $s; } ;# sub sockname ($) { my $self = shift; my $sock = $self->handle; if (defined($sock)) { my($port, $a) = sockaddr_in(getsockname($sock)); my $addr = join('.', unpack('C4', $a)); carp("$self sockname=$addr:$port") if $LOG > 7; return wantarray ? ($port, $addr) : "$addr:$port"; } return wantarray ? () : undef; } ;# sub peername ($) { my $self = shift; my $sock = $self->handle; if (defined($sock)) { my($port, $a) = sockaddr_in(getpeername($sock)); my $addr = join('.', unpack('C4', $a)); carp("$self sockpeer=$addr:$port") if $LOG > 7; return wantarray ? ($port, $addr) : "$addr:$port"; } return wantarray ? () : undef; } ;# end of Fan::TCP module ftpmirror-1.96/Fan/TCP/test.pl100644 1751 1750 3560 6405673116 14410 0ustar ikuouserBEGIN { $| = 1; print "1..15\n"; } END { print("not ok 1\n") unless $loaded; } use Fan::TCP; $loaded = 1; print("ok 1\n"); $Fan::TCP::LOG = 6; ref($srv = Fan::TCP->new()) or print("not ok 2\n"), exit(1); print("ok 2\n"); ref($clt = Fan::TCP->new(tcp_host => 'localhost', tcp_timeout => 3)) or print("not ok 3\n"), exit(1); print("ok 3\n"); $start = 31111; $end = $start + 10; for ($port = $start; $port <= $end; $port++) { last if $srv->do_server( tcp_bindaddr => '127.0.0.1', tcp_bindport => $port); warn("port# $port failed, try next\n"); } $port <= $end or print("not ok 4\n"), exit(1); print("ok 4\n"); $clt->do_client(tcp_port => $port) or print("not ok 5\n"), exit(1); print("ok 5\n"); ref($new = $srv->new_client) or print("not ok 6\n"), exit(1); print("ok 6\n"); !$clt->getln && $clt->error =~ /timed out/ or print("not ok 7\n"), exit(1); print("ok 7\n"); # force to clear error. $clt->clearerror(1); $clt->putln('ABCDEF') or print("not ok 8\n"), exit(1); print("ok 8\n"); $new->getln eq 'ABCDEF' or print("not ok 9\n"), exit(1); print("ok 9\n"); $new->putln('OPQRSTUVWXYZ') or print("not ok 10\n"), exit(1); print("ok 10\n"); $clt->getln eq 'OPQRSTUVWXYZ' or print("not ok 11\n"), exit(1); print("ok 11\n"); undef $new; undef $clt; undef $srv; # checking timeout routines... # ref($srv = Fan::TCP->new()) or print("not ok 12\n"), exit(1); print("ok 12\n"); for ($port++; $port <= $end; $port++) { last if $srv->do_server( tcp_bindaddr => '127.0.0.1', tcp_bindport => $port ); warn("port# $port failed, try next\n") if $Fan::TCP::LOG >= 6; } ref($clt = Fan::TCP->new(tcp_host => 'localhost')) or print("not ok 13\n"), exit(1); print("ok 13\n"); $clt->do_client(tcp_port => $port) or print("not ok 14\n"); print("ok 14\n"); ref($new = $srv->new_client) or print("not ok 15\n"), exit(1); print("ok 15\n"); undef $new; undef $clt; undef $srv; exit; ftpmirror-1.96/Fan/Usage/ 40755 1751 1750 0 7031563576 13415 5ustar ikuouserftpmirror-1.96/Fan/Usage/Makefile.PL100644 1751 1750 144 6401315315 15425 0ustar ikuouseruse ExtUtils::MakeMaker; WriteMakefile( 'NAME' => 'Fan::Usage', 'VERSION_FROM' => 'Usage.pm', ); ftpmirror-1.96/Fan/Usage/Usage.pm100644 1751 1750 5142 6402772441 15110 0ustar ikuouser;# ;# Copyright (c) 1995-1997 ;# 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: Usage.pm,v 1.8 1997/09/02 11:14:41 ikuo Exp $ ;# package Fan::Usage; use strict; use vars qw($VERSION @ISA @EXPORT $LOG); require Exporter; require DynaLoader; @ISA = qw(Exporter DynaLoader); @EXPORT = qw(getrusage); $VERSION = '0.02'; $LOG = 5; bootstrap Fan::Usage $VERSION; sub UsagePtr::dump { my $p = shift; printf("%10.4f user time used\n", $p->ru_utime); printf("%10.4f system time used\n", $p->ru_stime); printf("%10d maximum resident set size\n", $p->ru_maxrss); printf("%10d integral shared memory size\n", $p->ru_ixrss); printf("%10d integral unshared data size\n", $p->ru_idrss); printf("%10d integral unshared stack size\n", $p->ru_isrss); printf("%10d page reclaims\n", $p->ru_minflt); printf("%10d page faults\n", $p->ru_majflt); printf("%10d swaps\n", $p->ru_nswap); printf("%10d block input operations\n", $p->ru_inblock); printf("%10d block output operations\n", $p->ru_oublock); printf("%10d messages sent\n", $p->ru_msgsnd); printf("%10d messages received\n", $p->ru_msgrcv); printf("%10d signals received\n", $p->ru_nsignals); printf("%10d voluntary context switches\n", $p->ru_nvcsw); printf("%10d involuntary context switches\n", $p->ru_nivcsw); } ;# A special marker for AutoSplit. 1; __END__ ;# end of Fan::Usage module ftpmirror-1.96/Fan/Usage/Usage.xs100644 1751 1750 7501 6401315316 15120 0ustar ikuouser/* * Note: Perl5 extension. * Extended by Ikuo Nakagawa. */ #include #include #include #include #include #include /* */ typedef struct rusage Usage; #ifdef XS_VERSION #ifdef __cplusplus extern "C" { #endif #include "EXTERN.h" #include "perl.h" #include "XSUB.h" #ifdef __cplusplus } #endif #endif /* XS_VERSION */ static int not_here(s) char *s; { croak("%s not implemented on this architecture", s); return -1; } static double constant(name, arg) char *name; int arg; { errno = 0; switch (*name) { case 'R': if (strEQ(name, "RUSAGE_SELF")) return RUSAGE_SELF; if (strEQ(name, "RUSAGE_CHILDREN")) return RUSAGE_CHILDREN; break; } errno = EINVAL; return 0; not_there: errno = ENOENT; return 0; } MODULE = Fan::Usage PACKAGE = Fan::Usage Usage * getrusage(who = RUSAGE_SELF) int who PROTOTYPE: ;$ CODE: { SV *sv = perl_get_sv("Fan::Usage::LOG", FALSE); int log = sv ? SvIV(sv) : NULL; if (!(RETVAL = malloc(sizeof(Usage)))) XSRETURN_UNDEF; if (getrusage(who, RETVAL) < 0) { free(RETVAL); XSRETURN_UNDEF; } if (log > 5) { printf("Fan::Usage CREATING = %p\n", RETVAL); fflush(stdout); } ST(0) = sv_newmortal(); sv_setref_pv(ST(0), "UsagePtr", (void*)RETVAL); } MODULE = Fan::Usage PACKAGE = UsagePtr void DESTROY(data) Usage *data; PROTOTYPE: $ CODE: { SV *sv = perl_get_sv("Fan::Usage::LOG", FALSE); int log = sv ? SvIV(sv) : 5; if (log > 5) { printf("Fan::Usage DESTROYING = %p\n", data); fflush(stdout); } free(data); } double ru_utime(data) Usage * data PROTOTYPE: $ CODE: { RETVAL = (double)data->ru_utime.tv_sec + (double)data->ru_utime.tv_usec / 1000000.0; } OUTPUT: RETVAL double ru_stime(data) Usage * data PROTOTYPE: $ CODE: { RETVAL = (double)data->ru_stime.tv_sec + (double)data->ru_stime.tv_usec / 1000000.0; } OUTPUT: RETVAL long ru_maxrss(data) Usage * data PROTOTYPE: $ CODE: { RETVAL = data->ru_maxrss; } OUTPUT: RETVAL long ru_ixrss(data) Usage * data PROTOTYPE: $ CODE: { RETVAL = data->ru_ixrss; } OUTPUT: RETVAL long ru_idrss(data) Usage * data PROTOTYPE: $ CODE: { RETVAL = data->ru_idrss; } OUTPUT: RETVAL long ru_isrss(data) Usage * data PROTOTYPE: $ CODE: { RETVAL = data->ru_isrss; } OUTPUT: RETVAL long ru_minflt(data) Usage * data PROTOTYPE: $ CODE: { RETVAL = data->ru_minflt; } OUTPUT: RETVAL long ru_majflt(data) Usage * data PROTOTYPE: $ CODE: { RETVAL = data->ru_majflt; } OUTPUT: RETVAL long ru_nswap(data) Usage * data PROTOTYPE: $ CODE: { RETVAL = data->ru_nswap; } OUTPUT: RETVAL long ru_inblock(data) Usage * data PROTOTYPE: $ CODE: { RETVAL = data->ru_inblock; } OUTPUT: RETVAL long ru_oublock(data) Usage * data PROTOTYPE: $ CODE: { RETVAL = data->ru_oublock; } OUTPUT: RETVAL long ru_msgsnd(data) Usage * data PROTOTYPE: $ CODE: { RETVAL = data->ru_msgsnd; } OUTPUT: RETVAL long ru_msgrcv(data) Usage * data PROTOTYPE: $ CODE: { RETVAL = data->ru_msgrcv; } OUTPUT: RETVAL long ru_nsignals(data) Usage * data PROTOTYPE: $ CODE: { RETVAL = data->ru_nsignals; } OUTPUT: RETVAL long ru_nvcsw(data) Usage * data PROTOTYPE: $ CODE: { RETVAL = data->ru_nvcsw; } OUTPUT: RETVAL long ru_nivcsw(data) Usage * data PROTOTYPE: $ CODE: { RETVAL = data->ru_nivcsw; } OUTPUT: RETVAL long clk_tck(data) Usage * data PROTOTYPE: $ CODE: { RETVAL = sysconf(_SC_CLK_TCK); } OUTPUT: RETVAL ftpmirror-1.96/Fan/Usage/test.pl100644 1751 1750 2212 6401320031 14774 0ustar ikuouserBEGIN { $| = 1; print "1..1\n"; } END { print("not ok 1\n") unless $loaded; } $Fan::Usage::LOG = 6; use Fan::Usage; use strict; use vars qw($loaded); $loaded = 1; print("ok 1\n"); { my $usage = getrusage(0); for (my $i = 0; $i < 10000; $i++) { local *FILE; open(FILE, "/dev/null") && close(FILE); } print "$usage\n"; print "utime = ".$usage->ru_utime."\n"; print "stime = ".$usage->ru_stime."\n"; print "maxrss = ".$usage->ru_maxrss."\n"; print "ixrss = ".$usage->ru_ixrss."\n"; print "idrss = ".$usage->ru_idrss."\n"; print "isrss = ".$usage->ru_isrss."\n"; print "minflt = ".$usage->ru_minflt."\n"; print "majflt = ".$usage->ru_majflt."\n"; print "nswap = ".$usage->ru_nswap."\n"; print "inblock = ".$usage->ru_inblock."\n"; print "oublock = ".$usage->ru_oublock."\n"; print "msgsnd = ".$usage->ru_msgsnd."\n"; print "msgrcv = ".$usage->ru_msgrcv."\n"; print "nsignals = ".$usage->ru_nsignals."\n"; print "nvcsw = ".$usage->ru_nvcsw."\n"; print "nivcsw = ".$usage->ru_nivcsw."\n"; undef $usage; } print("ok 2\n"); { my $usage = getrusage; $usage->dump; print "clock tick = ".$usage->clk_tck."\n"; } print("ok 3\n"); #sleep(5); ftpmirror-1.96/Fan/Usage/typemap100644 1751 1750 31 6401012144 15022 0ustar ikuouserTYPEMAP Usage * T_PTROBJ ftpmirror-1.96/COPYRIGHT100644 1751 1750 2533 6401320022 13211 0ustar ikuouserCOPYRIGHT NOTICE All of the documentation and software included in this software distribution are copyrighted by Ikuo Nakagawa. 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. ftpmirror-1.96/Makefile.in100644 1751 1750 1741 6412744767 14017 0ustar ikuouserprefix= @prefix@ exec_prefix= @exec_prefix@ sysconfdir= @sysconfdir@ BINDIR= @bindir@ LIBDIR= @libdir@ SYSCONFDIR= @sysconfdir@ PERL= @PERL@ INSTALL= @INSTALL@ INSTALL_DATA= @INSTALL_DATA@ INSTALL_PROGRAM= @INSTALL_PROGRAM@ SUBDIR= Fan all:: clean:: realclean:: rm -f config.cache config.log config.status rm -f *.old *.bak *.core Makefile # install:: ${BINDIR}/farm install:: ${BINDIR}/rotate install:: ${BINDIR}/ftpmirror install:: ${SYSCONFDIR}/ftpmirror.cf-sample ${BINDIR}/rotate: rotate ${INSTALL_PROGRAM} $? $@ ${BINDIR}/farm: farm ${INSTALL_PROGRAM} $? $@ ${BINDIR}/ftpmirror: ftpmirror ${INSTALL_PROGRAM} $? $@ ${SYSCONFDIR}/ftpmirror.cf-sample: ftpmirror.cf-sample ${INSTALL_DATA} $? $@ # for subdirectories... all clean realclean install:: Fan/Makefile @ for d in ${SUBDIR} ; do \ ( echo "make $@ in $$d..." && cd $$d && make $@ ) ; \ done # Fan subdirectory requres Makefile first. Fan/Makefile:: Fan/Makefile.PL cd Fan; ${PERL} Makefile.PL ftpmirror-1.96/README.jis100644 1751 1750 77252 7031563474 13440 0ustar ikuouser << $B$O$8$a$K(B >> `ftpmirror' $B$O!"(BFTP $B$rMQ$$$F$"$k%G%#%l%/%H%j0J2<$N9=B$$r$^$k$4$H(B $B%3%T!<$9$k(B($B0J2Aw$O!"?75,%U%!%$%k$NDI2C$d!"JQ99$N$"$C$?>l9g$N$_9T$o$l(B $B$^$9$N$G8zN(E*$J%G%#%l%/%H%j%D%j!<$NF14|$,2DG=$G$9!#(B FTP $B%5!<%P$N%a%s%F%J%s%9$d!"(BWeb $B%5!<%P$N%3%s%F%s%DF14|!"$=$NB>!"(B $B%7%9%F%`$N%P%C%/%"%C%W$J$I!"?'!9$J>lLL$G$4MxMQ$$$?$@$1$^$9(B :-) $BF1MM$N$b$N$K(B `mirror' $B$H$$$&%=%U%H%&%'%"$,$"$j$^$9$,!"$3$l$OAPJ}(B $B$N$9$Y$F$N%U%!%$%k%j%9%H$r:n@.!"Hf3S$7$F$+$iE>Aw$r3+;O$9$k$?$a!"(B $BBg5,LO$J%G%#%l%/%H%j%D%j!<$NF14|$G$O%a%b%j(B($B$b$7$/$O0l;~%G%#%9%/(B) $B$NITB-$J$I$,LdBj$K$J$k$3$H$,$"$j$^$9!#(B $B:ne5-$N(B mirror $B%=%U%H$O;ve;H$$$b$N$K$J$i$J$+$C$?$?$a(B :-p $B7k6I!"(B $B%<%m$+$i:n$C$F$7$^$C$?$N$,(B `ftpmirror' $B$G$9!#(B ftpmirror $B$G$O!V?<$5M%@hC5:w!\=hM}$7$?>pJs$Ol9g$O(B perl 5.004 $B0J>e$,I,MW$G$9!#$^$:(B $B$*CHq$7$F$7$^$&$3$H$,$"$j$^$9!#:ne!"Bg$-$JLdBj$K$O!"$J$C$F$$$^$;$s!#(B $B8=>u$G$O(B perl 5.005 $B0J>e$rMxMQ$5$l$k$3$H$r$*4+$a$7$^$9!#(B << ftpmirror $B$N%$%s%9%H!<%k(B >> ftpmirror $B$N:G?7HG$O!"(Bftp.intec.co.jp $B$G8x3+$5$l$F$$$^$9!#0J2<$N(B URL $B$G<($5$l$k%G%#%l%/%H%j$+$i:G?7$N$b$N$r$r;}$D(B $B%"!<%+%$%V%U%!%$%k$K$J$C$F$$$^$9!#$3$l$rE,Ev$J%G%#%l%/%H%j$GE83+(B $B$7$F!"%$%s%9%H!<%k$r3+;O$7$^$9!#(B % cd /usr/local/src % gzip -cd < /tmp/ftpmirror-x.y.tar.gz | tar xf - $B>e5-%U%!%$%k$rE83+$9$k$H!"(Bftpmirror-x.y $B$H$$$&%G%#%l%/%H%j$,:n@.(B $B$5$l$^$9$N$G!"$=$N%G%#%l%/%H%j$K0\F0$7!"(Bconfigure $B$rl9g$O!"4D6-JQ?t(B PERL $B$K(B $B3:Ev$9$k(B path $B$rDj5A$7$F$+$i(B configure $B$rl9g$O(B % cd ftpmirror-x.y % env PERL=/usr/local/bin/perl5.005 ./configure $Be5-$N$h$&$K%$%s%9%H!<%k$9$k$H!"0J2<$N%U%!%$%k$,:n$i$l$^$9!#(B /usr/local/bin/ftpmirror /usr/local/bin/rotate /usr/local/etc/ftpmirror.cf-sample /usr/local/lib/perl5/site_perl/Fan.pm /usr/local/lib/perl5/site_perl/Fan/... $B0J2<%i%$%V%i%j(B /usr/local/lib/perl5/site_perl/auto/Fan/... $B0J2<%i%$%V%i%j(B $B"((B $B$?$@$7!"(Bperl $B$N%$%s%9%H!<%k;~$N@_Dj$K$h$C$F$O!"%i%$%V%i%j$N(B $B%$%s%9%H!<%k%G%#%l%/%H%j$O> ftpmirror $B$G$O!"%_%i!<$7$?$$%"!<%+%$%V(B($B0J2<$G$O%Q%C%1!<%8$bF15A(B) $B$4$H$K$$$/$D$+$N%Q%i%a!<%?$N;XDj$r9T$$$^$9!#%Q%i%a!<%?$O5/F0;~$N(B $B%*%W%7%g%s!"$b$7$/$O@_Dj%U%!%$%k$G;XDj$G$-$^$9!#(B $B$J$*!"@_Dj%U%!%$%k$O%G%U%)%k%H$G(B /usr/local/etc/ftpmirror.cf $B$H(B $B$J$C$F$$$^$9$,!"5/F0;~$K(B --load-config=/hogehoge/local.cf $B$H$$$&(B $B%*%W%7%g%s$r;XDj$9$k$3$H$K$h$C$F@_Dj%U%!%$%k$rJQ99$G$-$^$9!#$^$?!"(B --load-config+=/hogehoge/local.cf $B$H;XDj$9$k$H!">e5-$N%G%U%)%k%H(B $B@_Dj%U%!%$%k$N$"$H$K!";XDj$7$?@_Dj%U%!%$%k$rDI2C$GFI$_9~$`$3$H$b(B $B2DG=$G$9!#(B $B;XDj$G$-$k%Q%i%a!<%?$K$OAw%b!<%I$J$I$N;XDj$r9T$&!#(B $B@_Dj%U%!%$%k$G(B package $B%Q%i%a!<%?$K$h$C$F;XDj$9$k!#(B $B%*%W%7%g%s%Q%i%a!<%?(B : $B5/F0;~$K%3%^%s%I%i%$%s$+$i;XDj$5$l$k!#(B $B>e5-$N%Q%i%a!<%?$O!"(B($BB8:_$9$l$P(B)$B$3$N=g$K>e=q$-$7$J$,$i@_Dj$5$l$F(B $B$$$-$^$9!#$7$?$,$C$F!"%*%W%7%g%s%Q%i%a!<%?$,:GM%@h$H$J$j$^$9!#(B $B@_Dj%U%!%$%k$K$*$1$k%Q%i%a!<%?$N;XDj$O(B param-name = value $B$^$?$O(B param-name += value $B$H$7$F9T$$$^$9!#A0e5-$N%Q%i%a!<%?;XDj$O(B % ftpmirror --param-name=value ... $B$^$?$O(B % ftpmirror --param-name+=value ... $B$H$7$F9T$C$?>l9g$HF1MM$K$J$j$^$9!#(B << $B%Q%i%a!<%?$K$D$$$F(B >> $B0J2<$K!"5$/$@$5$$!#(B o $B%7%9%F%`$*$h$SF0:n$K4XO"$9$k%Q%i%a!<%?(B todo: (string, default: full-mirror) $B$l!"8e=R$N(B *-regexp $B$J$I$N%U%#%k%?$O@_Dj$5$l$?(B $B$&$($GAw$K4X$9$k>\:Y$J%m%0$r=PNO$7$?$$$H$-$K(B yes $B$K$9$k!#(Byes $B$N>l9g$K$O!"E>Aw$dJQ99$NI,MW$N$J$$%U%!%$%k$K$D$$$F$b%m%0$H(B $B$7$F=PNO$5$l$k!#(B log-mask: (comma separated list, default: $B$J$7(B) $B=PNO%m%0$K4X$9$kDj5A$r9T$&!#(Bftpmirror $B$GMxMQ$7$F$$$k(B perl $B%i%$%V%i%j$4$H$K=PNO%m%0$,Dj5A$G$-$k!#Nc$($P(B log-mask = Fan=6,Fan::FTP=7 $B$H$9$k$H!"E>Aw$dJQ99$N$J$$%U%!%$%k$N0lMw$K4X$9$k%m%0!"(BFTP $B$K4X$9$k>\:Y$J%m%0!"$J$I$,=PNO$5$l$k$h$&$K$J$k!#(B test-mode: (boolean, default: no) $BAw$r9T$J$o$:$K!"E>Aw$9$Y$-%U%!%$%k$@$1$rI=<($7$?$$(B $B>l9g$K(B yes $B$K$9$k!#(B o FTP $B$K4XO"$9$k%Q%i%a!<%?(B ftp-server: (string, default: $B$J$7!"%_%i!<;~$K$OI,?\(B) FTP $B$G@\B3$9$k%5!<%P$N%[%9%HL>!#(B ftp-gateway: (string, default: $B$J$7(B) TIS $B$N(B FireWall ToolKit $B$J$I$N(B proxy gateway $B$rMxMQ$9$k:]$K(B $B;XDj$9$k!#Nc$($P!"(B ftp-user = anonymous ftp-server = ring.etl.go.jp ftp-gateway = proxy.intec.co.jp $B$H;XDj$9$k$H!"$K$O(B anonymous@ring.etl.go.jp $B$,EO$5$l$k!#(B(ftp-pass $B$O$=$N$^$^MxMQ$5$l$k(B) server $B%Q%i%a!<%?$HAH$_9g$o$;$k$HJXMx!#(B ftp-port: (service, default: ftp) FTP $B@\B3$r9T$&:]!"@\B3$9$k%]!<%HHV9f$rJQ99$7$?$$>l9g$K;XDj(B $B$9$k!#DL>o$N(B FTP $B@\B3$G$O;XDj$9$kI,MW$O$J$$!#(B ftp-bindaddr: (ip address, default: $B$J$7(B) FTP $B$G@\B3$r9T$&>l9g$K!"%m!<%+%kB&$G;HMQ$9$k%"%I%l%9$rL@<((B $BE*$KDj5A$7$?$$>l9g$K!"$=$N(B IP $B%"%I%l%9$r;XDj$9$k!#%[%9%H$,(B $BJ#?t$N%M%C%H%o!<%/%$%s%?!<%U%'!<%9$r;}$D>l9g$J$I$d!"0l$D$N(B $B%$%s%?!<%U%'!<%9$KJ#?t$N%"%I%l%9$r3d$jEv$F$F$$$k>l9g$J$I!"(B $BL@<(E*$K%m!<%+%kB&$N%"%I%l%9$r;XDj$9$k$3$H$G!"%5!<%P$K;D$k(B $B%m%0$J$I$N>pJs$rL@3N$K$G$-$k>l9g$,$"$k!#DL>o$O;XDj$9$kI,MW(B $B$O$J$$!#(B ftp-user: (string, default: anonymous) FTP $B$N%m%0%$%sL>!#F?L>(B FTP $B$G$O(B anonymous $B$rMQ$$$k$N$,IaDL!#(B ftp-pass: (string, default: `whoami`@`hostname`) $B%Q%9%o!<%I!#F?L>(B FTP $B$G$O!"<+J,$N(B e-mail $B%"%I%l%9$r;XDj$9$k(B $B$N$,0lHLE*!#(B ftp-group: (string, default: $B$J$7(B) FTP $B%5!<%P$K%m%0%$%s$7$?$"$H!"%0%k!<%W$rJQ99$9$k>l9g$K;XDj(B $B$9$k!#(BSITE GROUP $B%3%^%s%I$rMxMQ$7$F$$$k!#l9g$K;XDj(B $B$9$k!#(BSITE GPASS $B%3%^%s%I$rMxMQ$7$F$$$k!#A0=R(B ftp-group $B$H(B $B6&$K;XDj$9$kI,MW$,$"$k!#(B ftp-passive: (boolean, default: no) $B%G!<%?$NE>Aw$G(B PASV $B$rMxMQ$9$k>l9g$K(B yes $B$K$9$k!#(Bno $B$N>l9g(B $B$K$O(B PORT $B%3%^%s%I$K$h$C$F%G!<%?E>AwMQ$N@\B3$r3NN)$9$k!#(B ftp-idle: (numeric, default: 0) SITE IDLE $B%3%^%s%I$rMQ$$$F!"(BFTP $B$N(B IDLE $B%?%$%^$rFCDj$NCM$K(B $B@_Dj$9$k!#CM$,(B 0 $B$J$iFC$K2?$b$7$J$$!#(B ftp-max-idle: (boolean, default: 0) SITE IDLE $B%3%^%s%I$rMQ$$$F(B FTP $B$N(B IDLE $B%?%$%^$r:GBg$K@_Dj$r(B $B$7$?$$>l9g$K(B yes $B$K$9$k!#(Bno $B$J$i2?$b$7$J$$!#>e5-$N(B ftp-idle $B$HF1;~$K;XDj$5$l$?>l9g$K$O(B ftp-max-idle $B$,M%@h$5$l$k!#(B ftp-list-method: (LIST or STAT or STAT-A or STAT-AT, default: STAT) FTP $B%5!<%P$+$i%G%#%l%/%H%j>pJs$rpJs$,(B control connection $B>e$GE>Aw$5$l$k$N$G!"(BLIST $B$KHf3S$9$k$H(B connection $B$rD%$kI,MW$,L5$$J,!"9bB.$G$"$k!#$?$@$7!"(BFTP $B%5!<%P%=%U%H$K(B $B$h$C$F$O(B STAT $B$G%G%#%l%/%H%j>pJs$rl9g$K$O(B ftp-list-method = LIST $B$H;XDj$9$k!#(B $B$^$?!"(BFTP $B%5!<%P$Nl9g$K!"%(%i!<$H$7$F07$&$h$&$K$7$?!#$3$N$h$&$J$3$H(B $B$,IQH/$9$k>l9g$K$O!"(Bftp-list-method $B$K(B LIST $B$r;XDj$9$k$HNI$$!#(B FTP $B%5!<%P$N$N%G%#%l%/%H%j>pJs$rl9g$,$"$k!#$=$N>l9g$O(B STAT-A $B$r;XDj$9$k$H%G%#%l%/%H%j>pJs$rl9g$J$I$O!"$3$NCM$rBg$-$/$9$k$HNI$$!#(B ftp-login-retry: (numeric, default: $B$J$7(B) FTP $B$N(B login $B$K<:GT$7$?>l9g(B($B@53N$K$O(B login $B;~$K%5!<%P$,(B 421 $B$N%3!<%I$rJV$7$FMh$?>l9g(B)$B!":FEY(B retry $B$r9T$$$?$$>l9g$K!"$=$N(B retry $B$N2s?t$r;XDj$9$k!#?M5$$N$"$k(B FTP $B%5!<%P$G$O!"%"%/%;%9(B $B$,=8Cf$7$?;~$K!"%f!<%6?t$N@)8B$K$h$C$F@\B3$,5qH]$5$l$k>l9g$,(B $B$"$k!#$=$N$h$&$J$3$H$,IQHK$K5/$3$k>l9g$J$I$K;XDj$9$k$HNI$$!#(B $B%G%U%)%k%H$G$O(B retry $B$O9T$o$J$$!#(B $B"(%?%$%`%"%&%H$K$h$k(B login $B<:GT;~$N(B retry $B$O!"$^$@!"%5%]!<%H(B $B$5$l$F$$$J$$!#:#8e%5%]!<%H$NM=Dj!#(B ftp-login-delay: (numeric, default: 60) ftp-login-retry $B$r;XDj$7$?>l9g!":FEY(B login $B$r9T$&$^$G$KBT$D(B $B;~4V$r;XDj$9$k!#C10L$OIC!#%G%U%)%k%H$O(B 60 $BIC!#(B0 $BIC$H;XDj$r(B $B$7$?>l9g$K$O!"(Bretry $B$J$7$HF1$807$$$K$J$k$N$GCm0U$9$k$3$H!#(B ftp-stats: (boolean, default: no) $B%_%i!<=*N;8e!"(Bftp $B$K$h$kAmDL?.NL$r=PNO$5$;$?$$>l9g$K(B yes $B$K(B $B;XDj$9$k!#(Bcontrol connection in/out, data connection in/out $B$N>pJs$,(B octet $BC10L$G=PNO$5$l$k!#(B remote-timezone: (timezone string, default: undef) $B%5!<%P$N(B ls -l $B$K$h$kF|IU$,(B GMT $B$+$i$I$l$@$1$:$l$F$$$k$+;XDj(B $B$9$k!#Nc$($P(B FTP $B%5!<%P$,(B ls -l $B$NF|IU$r(B JST $B$GI=<($7$F$$$k(B $B>l9g!"(Bremote-timezone $B$r(B +0900 $B$K$9$k!#$?$@$7!"8=:_$O(B summer time $B$K$OL$BP1~!#(Bremote-timezone $B$,;XDj$5$l$F$J$1$l$P;~F0E*(B $B$K7W;;$5$l$k$N$G!"IaDL$O;XDj$9$kI,MW$O$J$$!#(B http-proxy: (string, default: $B$J$7(B) FTP $B%5!<%P$X$N%"%/%;%9l9g$K!"(B http proxy server $B$N%[%9%HL>(B($B$*$h$S%]!<%HHV9f(B)$B$r;XDj$9$k!#(B $B$3$N>l9g!"(Bftpmirror $B$O(B http proxy server $B$H$N4V$G(B HTTP $B$G$N(B $BDL?.$r9T$&$3$H$K$J$k!#$?$@$7%G%#%l%/%H%j>pJs$r(B HTTP $B$G@\(B FTP $B$,5v$5(B $B$l$F$$$J$$>l9g$J$I$O!"e$KE>Aw$7$?$$(B $B>l9g$K(B yes $B$K$9$k!#Nc$($P!"5G'$rF@$?(B Web $B$N(B $B%3%s%F%s%D$r%P%j%"%;%0%a%s%H>e$K%3%T!<$9$k$K$O!"]$H$J$C$?%U%!%$%k$r!"C$9>l9g$K(B yes $B$r;XDj$9$k!#(B $B:o=|BP>]$H$J$C$?%U%!%$%k$b:o=|$;$:$K;D$9>l9g$K$O(B no $B$K$9$k!#(B unlink $B$K(B rename $B$r;XDj$9$k$H!":o=|BP>]$H$J$C$?%U%!%$%k$O(B $B%U%!%$%kL>$NKvHx$K(B `~' $B$r$D$1$?%U%!%$%kL>$K(B rename $B$5$l$k!#(B unlink-limit: (size value, default: 0) !!! $B8=:_$O%5%]!<%H$7$F$$$J$$$N$GCm0U(B $B$3$N%Q%i%a!<%?$rDj5A$9$k$3$H$K$h$C$F!"$"$kFCDj$N%5%$%:0J>e$N(B $B%U%!%$%k$d%G%#%l%/%H%j$r>C$5$J$$$h$&$K@_Dj$G$-$k!#(B $B$3$N%Q%i%a!<%?$K$h$j!"%5!<%P>e$G%D%j!<$,:F9=@.$5$l$?>l9g$K!"(B $B8m$C$F$9$Y$F$N%U%!%$%k$r>C$7$F$7$^$&$h$&$J;v8N$rKI$0$3$H$,(B $B2DG=$K$J$C$?!#(B $BNc$($P(B unlink-limit = 30M $B$N>l9g!"(B30$B%a%,%P%$%H0J>e$N%U%!%$%k(B $B$d%G%#%l%/%H%j$O:o=|$5$l$J$$!#F1MM$K(B 500K $B$d(B 2G $B$J$I$N;XDj$b(B $B2DG=!#$^$?!"C10L$rIU$1$:$K(B unlink-limit = 100 $B$H$9$k$H!"(B100 $B0J>e$N%(%s%H%j$r;}$D%G%#%l%/%H%j$r:o=|$7$J$$$H$$$&0UL#$K$J$k!#(B ftp-force-mtime: (boolean, default: no) $B%5!<%P>e$N%U%!%$%k$H<+J,$N%[%9%H>e$N%U%!%$%k$rHf3S$9$k:]$K(B $B%5!<%P>e$N%U%!%$%k$N:G=*99?7;~4V$r(B MDTM $B$K$h$C$FF@$?$$>l9g(B yes $B$K$9$k!#(Bno $B$N>l9g$K$O!"%U%!%$%kE>Aw;~0J30(B MDTM $B$OH/9T(B $B$7$J$$!#(B ignore-mtime: (boolean, default: no) $B%G%U%)%k%H$G$O(B ftpmirror $B$O%U%!%$%k$N:G=*99?7;~4V$r%A%'%C%/(B $B$9$k$,!"$3$N%Q%i%a!<%?$,(B yes $B$K%;%C%H$5$l$F$$$k$H!"%U%!%$%k(B $B$N%5%$%:$@$1$GHf3S$r9T$&!#$3$N>l9g$O!"%5!<%PB&$N%U%!%$%k$H(B $B<+J,$N%[%9%HB&$N%U%!%$%k$,F1$8%5%$%:$G$"$l$P!":G=*99?7;~4V(B $B$@$1$,JQ99$5$l!"Aw$O9T$o$J$l$J$$!#(B temp-directory: (pathname, default: $TMPDIR || /tmp) ls-lR $B$d%G%#%l%/%H%j>pJs$J$I$N%U%!%$%k$r0l;~E*$KJ]B8$9$k$?$a(B $BMxMQ$5$l$k%G%#%l%/%H%j$r;XDj$9$k!#(B lock-directory: (pathname, default: temp-directory) $BJ#?t$N(B ftpmirror $B$,F1;~$KF1$8%Q%C%1!<%8$N%_%i!<$r9T$&$3$H$r(B $BHr$1$k$?$a!"(Block $B%U%!%$%k$r:n@.$9$k%G%#%l%/%H%j$r;XDj$9$k!#(B create-directory: (boolean, default: yes) local-directory, temp-directory, lock-directory $B$J$I$,B8:_(B $B$7$J$+$C$?>l9g$K%G%#%l%/%H%j$r:n@.$9$k$+$I$&$+$r;XDj$9$k!#(B create-directory $B$,(B no $B$G!"3:Ev$N%G%#%l%/%H%j$,$J$1$l$P!"(B $B%(%i!<$K$J$k!#(B remote-directory: (string, default: $B$J$7!"%_%i!<;~$OI,?\(B) $B%_%i!<$9$k%5!<%P>e$N%G%#%l%/%H%j$r;XDj$9$k!#%_%i!<$O!"$3$N(B $B%G%#%l%/%H%j$+$i:F5"E*$K9T$J$o$l$k!#(B $BJ8;zNsCf$K4^$^$l$k(B %s $B$O%Q%C%1!<%8L>$KCV49$5$l$k!#H$N$3$H!#(B local-directory: (pathname, default: $B$J$7!"%_%i!<;~$OI,?\(B) ftpmirror $B$,e$N!"%?!<%2%C%H%G%#%l%/%H%j!#(B $B>e5-(B remote-directory $B$KBP1~$9$k$b$N$r;XDj$9$k!#(B $BJ8;zNsCf$K4^$^$l$k(B %s $B$O%Q%C%1!<%8L>$KCV49$5$l$k!#$^$?@hF,(B $B$,(B `~'(tilda) $B$+$i$O$8$^$k>l9g!"(Bcsh $BF1MM$N(B path $BL>$NCV49$,(B $B;\$5$l$k!#(B local-directory $B$K;XDj$5$l$k%G%#%l%/%H%j$O%m!<%+%k%[%9%H>e(B $B$KB8:_$7$F$$$kI,MW$,$"$k!#(B($B8E$$%P!<%8%g%s$N(B ftpmirror $B$G$O(B mkdir $B$7$?$,!";v8N$rKI$0$?$a;EMM$,JQ99$K$J$C$?$N$GCm0U(B) $BNc$($P!"(Bftpmirror $B$,e$N(B /pub/FreeBSD $B0J2<$r!"%m!<%+%k%[%9%H$N(B /var/ftp/pub/FreeBSD $B$K%_%i!<$9$k!#(B package = FreeBSD ftp-server = ftp.FreeBSD.ORG remote-directory = /pub/%s local-directory = ~ftp/pub/%s master-db-directory: (pathname, default: $B$J$7(B) ftpmirror $B$O%m!<%+%k%[%9%H>e$N%U%!%$%k$N0lMw!"$*$h$SA02s$N(B $B%_%i!<$+$i$N:9J,$r%G!<%?%Y!<%9$H$7$F4IM}$G$-$k!#$3$N5!G=$r(B $BMxMQ$9$k>l9g$K$O!"(Bmaster-db-directory $B$r;XDj$7$F!"3:Ev$9$k(B $B%G%#%l%/%H%j$r:n@.$7$F$*$/!#(B master-db-directory $B$b(B local-directory $BF1MM!"(B`~'(tilda) $B$K(B $B$h$k%[!<%`%G%#%l%/%H%j$NCV49$H(B %s $B$K$h$k%Q%C%1!<%8L>$NCV49(B $B$r9T$&!#(B $Bl9g$G$b(B master-db-directory $B$rMQ$$$?%G%#%l%/%H%j%D%j!<$N4IM}$,2DG=$G!"l9g$K$Ol9g!"(B $Bl9g!"%G!<%?%Y!<%9$r(B $BMQ$$$F8zN(E*$J%_%i!<$,2DG=$K$J$k!#$3$3$G$O!"$3$l$r(B slave mode mirror $B$H8F$V!#$3$N5!G=$O(B remote-db-directory $B$*$h$S!"(B local-db-directory $B$r;XDj$7!"(Blocal-db-directory $B$K3:Ev$9$k(B $B%G%#%l%/%H%j$r:n@.$7$F$*$/$3$H$GMxMQ2DG=$K$J$k!#$J$*!"(B remote-db-directory $B$O!"%5!<%P>e$N(B master-db-directory $B$K(B $B$"$?$k%G%#%l%/%H%jL>$r;XDj$9$k!#(B $B$3$l$i$N%Q%i%a!<%?$b(B local-directory $BF1MM(B %s $B$NCV49$r9T$&!#(B $B$^$?(B local-db-directory $B$O(B `~'(tilda) $B$K$h$k%G%#%l%/%H%jL>(B $BCV49$b9T$o$l$k!#(B ftpmirror $B$O(B remote-db-directory, local-db-directory $B$,;XDj(B $B$5$l$F$$$k>l9g!"$^$:%5!<%P>e$N(B master-db-directory $B$NCf?H$N(B $BF14|$r9T$$!"$=$N8e!"pJs$rMQ$$$F%_%i!<(B $B$r3+;O$9$k!#$3$N>l9g!"$9$Y$F$N%U%!%$%k$N>pJs$O%G!<%?%Y!<%9$K(B $B4^$^$l$F$$$k$N$G!"(BLIST $B$d(B STAT $B$K$h$k%U%!%$%k$N>pJs$NAw;~!">c32;~0J30(B $Be$GE>Aw$5$l$k$N$O(B step $B%U%!%$%k$@$1$G$"$k!#(B (FreeBSD $B$N(B full distribution $B$G(B index $B%U%!%$%k$,(B 10Mbytes$B!"(B $BKhF|$N(B step $B%U%!%$%k$,?t==!A?tI4(BKbytes $B$G$"$k$3$H$r9M$($k$H!"(B $B$3$l$OHs>o$K%M%C%H%o!<%/$N;HMQ8zN($,NI$$$O$:$G$"$k!#(B) $BNc$($P!"A0=R$N(B master-db-directory $B$G%G!<%?%Y!<%9$r4IM}$7$F(B $B$$$k%5!<%P$+$i(B `slave mode mirror' $B$r9T$&>l9g$K$Oe5-(B $B$NNc$H$^$C$?$/F1MM$N@_Dj$G!"(Bftpmirror $B$N5/F0;~$K(B % ftpmirror --todo=step-mirror FreeBSD $B$H$7$F5/F0$9$k$H!"(Bstep $B%U%!%$%k$K$"$k>pJs$@$1$r$b$H$K:9J,(B $B%_%i!<$r9T$&$3$H$,$G$-$k!#(B $B6qBNE*$JE}7W$O$^$@$@$,!"$*$=$i$/(B step mirror $B$r(B daily $B$K!"(B full mirror $B$r(B weekly $BDxEY$K9T$&!"$J$I$N$h$&$K$9$k$HHs>o$K(B $B8zN(E*$J%_%i!<$,$G$-$k$b$N$H;W$o$l$k!#(B lslR-file: (string, default: $B$J$7(B) FTP $B%5!<%P>e$K(B ls-lR.Z $B$J$I$N%U%!%$%k$,=`Hw$5$l$F$$$k>l9g$K!"(B STAT/LIST $B$K$h$k%G%#%l%/%H%j%9%-%c%s$NBX$o$j$K!"$3$N%U%!%$%k(B $B$rMQ$$$F%G%#%l%/%H%j%(%s%H%j$rD4$Y$k!#(Bgz $B$d(B Z $B$G=*$k>l9g$K$O(B $B<+F0E*$K(B gunzip/uncompress $B$9$k!#Nc$($P(B ftp.freebsd.org $B$N(B /pub/FreeBSD $B0J2<$r(B ls-lR.gz $B$rMQ$$$F%_%i!<$7$?$$>l9g$K$O!"(B $Bl9g!"(B remote-directory $B0J2<$NAjBP%Q%9$H$7$F07$o$l$k!#(B lslR-copy: (pathname, default: $B$J$7(B) lslR-file $B$r%m!<%+%k%[%9%H>e$K%3%T!<$7$FJ]B8$7$F$*$-$?$$>l9g(B $B$K;XDj$9$k!#AjBP%Q%9(B(`/' $B$+$i$O$8$^$i$J$$J8;zNs(B)$B$,;XDj$5$l$?(B $B>l9g$K$O!"(Blocal-directory $B$+$i$NAjBP%Q%9$H$7$F07$o$l$k!#$3$N(B $B;XDj$r9T$C$?>l9g$K$O!"(BlslR-file $B$rE>Aw$7$?>l9g!"$=$N%3%T!<$,(B lslR-copy $B$KJ]B8$5$l!"Aw$rM^@)$9$k$3$H$,$G$-$k!#(B $B$^$?(B lslR-copy $B$,AjBP%Q%9$N>l9g$K$O(B override-file $B$K<+F0E*$K(B $B%U%#%k%?$,@_Dj$5$l$k!#$?$@$7(B lslR-copy $B$,@dBP%Q%9$N>l9g$K$O!"(B $B$3$N%U%#%k%?$O@_Dj$5$l$J$$$N$G!"(Blocal-directory $B0J2<$K%3%T!<(B $B$rCV$/>l9g$K@dBP%Q%9$G=q$$$F$7$^$&$H!"%_%i!l9g$G$b!"(BlslR-copy $B$,;XDj(B $B$5$l$F$$$l$P(B ls-lR $B%U%!%$%k$rMQ$$$?%_%i!<$,2DG=$G$"$k!#$3$l$O(B $BF0:n3NG'$d(B ls-lR $B%U%!%$%k$rl9g$J$I$KMxMQ$9$k(B $B$HJXMx$G$"$k!#(B transfer-file-regexp: (regexp, default: $BA4$F$K%^%C%A(B) GET $B$9$k%U%!%$%kL>$K%^%C%A$9$k@55,I=8=!#%5!<%P>e$N%U%!%$%k$O(B `./' $B$+$i$O$8$^$k(B remote-directory $B$+$i$NAjBP%Q%9$GI=$5$l$k!#(B $BNc$($P(B remote-directory = /pub/FreeBSD $B$N>l9g!"%5!<%P>e$N(B /pub/FreeBSD/2.1.0-RELEASE/README.TXT $B$H$$$&%U%!%$%k$O(B ./2.1.0-RELEASE/README.TXT $B$K$J$k!#(B $B0J2Aw$9$k!#(B ($B:G=*9T$O%G%U%)%k%H$G(B GET $B$7$J$$$3$H$r;XDj$7$F$$$k(B) regexp += /\/bash-/ regexp += /\/gcc-/ regexp += ! transfer-directory-regexp: (regexp, default: $BA4$F$K%^%C%A(B) $B%5!<%P>e$N%G%#%l%/%H%j$G!"%5!<%A$7$?$$(B *$B%G%#%l%/%H%j(B* $B$rI=$9(B $B@55,I=8=!#DL>o%U%!%$%k$KBP$7$F$O0UL#$r;}$?$J$$!#(BFTP $B%5!<%P>e$N(B $B$9$Y$F$N%G%#%l%/%H%j$O(B '/' $B$,IU2C$5$l$?>uBV$GHf3S$5$l$k!#Nc$($P(B $Be$G>e=q$-$7$F$h$$%U%!%$%k(B $B$rI=$9@55,I=8=!#Aw$5$l$k%U%!%$%k$O(B transfer-file-regexp $B$K%^%C%A$7!"$+$D(B override-file-regexp $B$K%^%C%A$9$k$b$N$K$J$k!#(B override-file-regexp $B$OJQ99$5$l$k2DG=@-$N$"$k%U%!%$%kL>$rI=8=(B $B$7$F$$$k$N$G!"$3$l$K%^%C%A$7$J$$%U%!%$%k$O!V>C$5$l$J$$!W$3$H$r(B $B0UL#$9$k!#(B $BNc$($P!"0J2<$NNc$G$O!"(Bbash-* $B$K$"$?$k%U%!%$%k$NE>Aw$O9T$&$,!"(B $B$3$l$K$"$?$i$J$$%U%!%$%k$O0l@ZJQ99$5$l$J$$(B override-file-regexp += /\/bash-/ override-file-regexp += ! override-directory-regexp: (regexp, default: $BA4$F$K%^%C%A(B) $B%m!<%+%kB&$G!"%_%i!<$N$?$a$K%5!<%A$7$?$$(B *$B%G%#%l%/%H%j(B* $B$rI=$9(B $B@55,I=8=!#DL>o%U%!%$%k$KBP$7$F$O0UL#$r;}$?$J$$!#5-=RJ}K!$O>e5-(B transfer-directory-regexp $B$HF1MM!#(B $B$3$l$rMxMQ$9$k$HFCDj$N%G%#%l%/%H%j0J2<$K!"JL%Q%C%1!<%8$r%_%i!<(B $B$9$k$3$H$b2DG=$G$"$k!#(B $BpJs$,$"$k>l9g$=$l$r(B $BMxMQ$9$k$J$i(B 1 $B$r;XDj$9$k!#%G%#%l%/%H%j>pJs$O8e=R!#(B store-local-dirinfo: (boolean, default: no) $B%m!<%+%kB&$N3F%G%#%l%/%H%j$K%G%#%l%/%H%j>pJs$r:n@.$9$k$+$I$&$+(B $B$r;XDj$9$k!#(B1 $B$N>l9g$K$O!"(B``.dirinfo'' $B$HL>A0$N%U%!%$%k$,3F(B $B%G%#%l%/%H%j$K:n@.$5$l$k!#%G%#%l%/%H%j>pJs$O8e=R!#(B load-remote-dirinfo: (boolean, default: no) $B%5!<%PB&$G:n@.$5$l$?%G%#%l%/%H%j>pJs$rMxMQ$9$k>l9g$K(B 1 $B$r;XDj(B $B$9$k!#(B1 $B$N>l9g!"%5!<%PB&$N%G%#%l%/%H%j$K(B ``.dirinfo'' $B$H$$$&(B $BL>A0$N%U%!%$%k$,$"$l$P!"(BSTAT/LIST $B$r;H$o$:$K!"$3$N%U%!%$%k$+$i(B $BpJs$+$i%_%i!<$r3+;O$9$k!#%G%#%l%/%H%j>pJs$O8e=R!#(B override-file-uid: (uid, default: 0) $B%_%i!<$NBP>]$K$J$C$F$$$k%m!<%+%k%U%!%$%k$d%G%#%l%/%H%j$N%*!<%J(B $B$r;XDj$9$k!#E>Aw$r9T$&(B / $B9T$o$J$$$K$h$i$:(B override-*-regexp $B$K(B $B%^%C%A$9$k$9$Y$F$N%U%!%$%k!"%G%#%l%/%H%j$N%*!<%J$rJQ99$9$k!#(B root $B0J30$N%f!<%6$K$h$C$Fl9g$K$O0UL#$r;}$?$J$$!#(B override-file-gid: (uid, default: 0) $B%_%i!]$K$J$C$F$$$k%m!<%+%k%U%!%$%k$d%G%#%l%/%H%j$N%0%k!<%W(B $B$r;XDj$9$k!#E>Aw$r9T$&(B / $B9T$o$J$$$K$h$i$:(B override-*-regexp $B$K(B $B%^%C%A$9$k$9$Y$F$N%U%!%$%k!"%G%#%l%/%H%j$N%0%k!<%W$rJQ99$9$k!#(B root $B0J30$N%f!<%6$K$h$C$Fl9g$K$O0UL#$r;}$?$J$$!#(B $B$J$*!">e5-$N(B override-file-uid $B$^$?$O(B override-file-gid $B$N$$$:(B $B$l$+$,;XDj$5$l$F$$$l$P!"%m!<%+%k%U%!%$%k$KBP$7$F(B chown $B$,]$K$J$C$F$$$k%m!<%+%k%U%!%$%k$N%b!<%I$r;XDj$9$k!#(B $BE>Aw$r9T$&(B / $B9T$o$J$$$K$h$i$:(B override-*-regexp $B$K%^%C%A$9$k(B $B$9$Y$F$N%U%!%$%k$N%b!<%I$rJQ99$9$k!#$?$@$7(B 0777 $B$G%^%9%/$5$l(B $B$k$?$a!"(Bsetuid/setgid $B$O@_Dj$G$-$J$$!#(B override-directory-mode: (octal value, default: 0755) $B%_%i!]$K$J$C$F$$$k%m!<%+%k%G%#%l%/%H%j$N%b!<%I$r;XDj$9$k!#(B $BE>Aw$r9T$&(B / $B9T$o$J$$$K$h$i$:(B override-*-regexp $B$K%^%C%A$9$k(B $B$9$Y$F$N%G%#%l%/%H%j$N%b!<%I$rJQ99$9$k!#(B default-file-uid: (uid, default: 0) $BE>Aw$r9T$C$?%U%!%$%k$N%G%U%)%k%H$N%*!<%J$r;XDj$9$k!#(Bftpmirror $B$O(B override-file-uid / $B%5!<%P>e$N%*!<%J(B / default-file-uid $B$N(B $B=g$KD4$Y$F%U%!%$%k$N%*!<%J$r7hDj$9$k!#(B default-file-gid: (gid, default: 0) $BE>Aw$r9T$C$?%U%!%$%k$N%G%U%)%k%H%0%k!<%W$r;XDj$9$k!#(Bftpmirror $B$O(B override-file-gid / $B%5!<%P>e$N%0%k!<%W(B / default-file-uid $B$N=g$KD4$Y$F%U%!%$%k$N%0%k!<%W$r7hDj$9$k!#(B default-file-mode: (octal value, default: 0644) $BE>Aw$r9T$C$?%U%!%$%k$N%G%U%)%k%H$N%b!<%I$r;XDj$9$k!#(Bftpmirror $B$O(B override-file-mode / $B%5!<%P>e$N%b!<%I(B / defalt-file-mode $B$N(B $B=g$KD4$Y$F%U%!%$%k$N%b!<%I$r7hDj$9$k!#$?$@$7!"(B0777 $B$G(B mask $B$r(B $B$+$1$k$?$a(B setuid/setgid $B$OMn$H$5$l$k!#(B default-directory-mode: (octal value, default: 0755) $B99?7$5$l$?%G%#%l%/%H%j$N%G%U%)%k%H$N%b!<%I$r;XDj$9$k!#(Bftpmirror $B$O(B override-directory-mode / $B%5!<%P>e$N%b!<%I(B / defalt-file-mode $B$N=g$KD4$Y$F%G%#%l%/%H%j$N%b!<%I$r7hDj$9$k!#(B << ftpmirror $B$N> $BA0=R$N@_Dj$r=*$($?$N$A!"(Bftpmirror $B$rl9g$K$O!"$r0z?t$KEO$7$^$9!#(B % ftpmirror FreeBSD ftpmirror $B$ODj5A%U%!%$%k(B($B%G%U%)%k%H(B: /usr/local/etc/ftpmirror.cf) $B$rFI$_9~$_!"3:Ev$9$k%Q%C%1!<%8$N%_%i!<$r3+;O$7$^$9!#(B $B$^$?!"%Q%C%1!<%8$OJ#?t$7$F$$$9$k$3$H$b2DG=$G$9!#Nc$($P> ftpmirror $B$K4X$7$F!"5$3Z$K> $BK\%=%U%H%&%'%"$O$?$/$5$s$NJ}$N%P%0%l%]!<%H$HDs0F!"6(NO$N$b$H$G$3$3(B $B$^$G0i$C$F$-$^$7$?(B :-) $BFC$K(B RingProject $B$G$O(B ftpmirror $B$N2W9s$JBQ5W(B $B;n83(B(?)$B$H$H$b$K!"H*;3$5$s$N(B patch $B$r$O$8$a!"$d$5$^$6$^$J2~NI$r$7$F(B $B$$$?$@$-$^$7$?!#(B $B$^$?(B ftpmirror $B%a!<%j%s%0%j%9%H$G$b!"B?$/$NJ}$+$i%P%0%U%#%C%/%9$d!"(B $BDs0F$J$I$r$$$?$@$-$^$7$?!#(B ftpmirror $B$N3+H/$K8f6(NO$/$@$5$C$?3'MM$K!"2~$a$F46(B >> Copyright $B$K$D$$$F$O(B COPYRIGHT $B$H$$$&%U%!%$%k$K5-=R$5$l$F$$$^$9$N$G!"(B $B$=$A$i$r;2>H$7$F2<$5$$!#(B $B%3%a%s%H!"%P%0%U%#%C%/%9!"Ds0F$J$I$O(B ikuo@jp.freebsd.org $B$^$G!#(B Dec 27, 1999 by Ikuo Nakagawa ftpmirror-1.96/RELEASE.jis100644 1751 1750 10147 7031563474 13551 0ustar ikuouser ftpmirror-1.96 $B$N$40FFb(B * $B$O$8$a$K(B ftpmirror-1.2 $B7ONs$N(B ftpmirror $B$r!"$[$H$s$I%<%m$+$i:n$j(B $BD>$7!"(Bftpmirror-2.0 $B$N3+H/$re$,(B $B2a$.$?$G$7$g$&$+!#$J$s$@$+$s$@$HK;$7$/$FA4A3:n6H$,?J$s$G(B $B$$$J$+$C$?$N$G$9$,!"$$$/$D$+$N%P%0$rD>$9$@$1$G$b$H(B 1.96 $B$r%j%j!<%9$9$k$3$H$K$J$j$^$7$?!#(B $B$^$@$$$/$D$+$N%P%0$O;D$C$F$$$^$9$,!";~4V$,$7$F$$$3$&$H;W$$$^$9!#(B * $BJQ99E@$K$D$$$F(B $B5lMh$N(B 1.2k $B$+$i$NJQ99E@$O(B($B;3$[$I$"$C$F=q$-@Z$l$J$$$1$I(B) $B@\=hM}$G$-$k$h$&$K$J$C$?!#(B o http proxy $B$r;H$C$?%_%i!<$,$G$-$k$h$&$K$J$C$?!#(B ($B$?$@$7(B dirinfo $B$d(B ls-lR $B$J$I$rMxMQ$9$kI,MW$,$"$k(B) o AutoSplit $B$rMQ$$$F8zN(E*$J%m!<%I$r9T$&$h$&$K$7$?!#(B o $B?7$?$K(B INDEX $B%b!<%I$r%5%]!<%H!#:9J,4IM}$J$I$b4^$a(B $B8zN(E*$J%_%i!<$,$G$-$k$h$&$K$J$kM=Dj!#(B o $B$5$i$K4JC1$J@_Dj$,$G$-$k$h$&$K%G%#%l%/%H%jL>$NCV49(B $B$rpJs(B $B:G?7$N%P!<%8%g%s(B 1.96 $B$G$O0J2<$NLdBj!"$*$h$S%P%0$r2~A1$7$^(B $B$7$?(B($B$7$?$D$b$j$G$9(B)$B!#(B o wu-ftpd $B$J$I$G(B STAT $B%3%^%s%I$KLdBj$,@8$8$k%1!<%9$KBP1~(B $B$G$-$k$h$&$K$7$?!#(B o $B%*!<%J$d%0%k!<%W$K(B `_' $B$,F~$C$F$$$k$H%_%i!<$K<:GT$9$k(B $BLdBj$KBP1~$7$?!#(B * $B%P!<%8%g%s$K$D$$$F(B $B8=:_$N%P!<%8%g%s$O(B 1.96 $B$G$9!#$3$N$"$H(B 1.97, 1.98,... $B$H(B $BA}$($F$$$C$F!"@5<0%j%j!<%9$O(B 2.0 $B$NM=Dj$G$9!#$?$@$7(B *$BCn(B* $B$, 1.991 $B$H(B $B$$$&J,4t$r$9$k$+$b$7$l$^$;$s(B :-p * $B%$%s%9%H!<%kJ}K!$K$D$$$F(B $B$3$N%P!<%8%g%s$+$i$O(B configurable $B$K$J$C$F$$$^$9!#(B % ./configure % make % su # make install $B$H$9$l$P(B /usr/local/bin/ftpmirror $B$HI,MW$J(B perl library $B$,%$%s%9%H!<%k$5$l$^$9!#$J$*!"(Bperl library $B$O!"Nc$($P(B /usr/local/lib/perl5/site_perl $B$J$I$N!"%5%$%HDI2C%i%$%V%i%j$H$7$F%$%s%9%H!<%k$5$l$^$9!#(B $BDI2C$5$l$k%b%8%e!<%k$O(B Fan.pm Fan/Attrib.pm Fan/Cool.pm Fan/DIR.pm Fan/FTP.pm Fan/Farm.pm Fan/HTTP.pm Fan/Loader.pm Fan/MD5.pm Fan/Param.pm Fan/Scan.pm Fan/TCP.pm Fan/Usage.pm $B$H!"$=$l$+$iGI@8$9$k%*%V%8%'%/%H$J$I$G$9!#(B $B$^$?!"%G%U%)%k%H$G$O(B /usr/local/etc/ftpmirror.cf-sample $B$bF1;~$K%$%s%9%H!<%k$5$l$^$9!#$3$N%U%!%$%k$r%3%T!<$7$F!"(B $B\:Y$O(B README.jis $B$K5-=R$5$l$F$$$^$9!#(B * $BCx:n8"$K$D$$$F(B $BK\%=%U%H%&%'%"!"$*$h$S!"E:IU%I%-%e%a%s%H$K4X$9$kCx:n8"$O(B COPYRIGHT $B%U%!%$%k$N5-=R$K=>$&$b$N$7$^$9!#(B $BCm(B: $B$J$*!">e5-%U%!%$%k$K5-=R$5$l$?FbMF$O(B FreeBSD $B$J$I$H(B $BF1MM$NFbMF$H$J$C$F$$$^$9!#(B * $Be$2$^$9!#(B $B$"$j$,$H$&$4$6$$$^$7$?!#(B $B!t(B $B$C$F!"$h$m$7$/$*4j$$$7$^$9(B $B!d(B $B3'MM!#(B * $B$*$o$j$K(B $B%3%a%s%H!"Ds0F!"%P%0Js9p$J$I$O!"(Bikuo@jp.freebsd.org $B08$K(B $B$40lJs$$$?$@$1$k$H9,$$$G$9!#(B Dec 27, 1999, Ikuo Nakagawa ftpmirror-1.96/configure100755 1751 1750 74154 6401320024 13657 0ustar ikuouser#! /bin/sh # Guess values for system-dependent variables and create Makefiles. # Generated automatically using autoconf version 2.12 # Copyright (C) 1992, 93, 94, 95, 96 Free Software Foundation, Inc. # # This configure script is free software; the Free Software Foundation # gives unlimited permission to copy, distribute and modify it. # Defaults: ac_help= ac_default_prefix=/usr/local # Any additions from configure.in: # Initialize some variables set by options. # The variables have the same names as the options, with # dashes changed to underlines. build=NONE cache_file=./config.cache exec_prefix=NONE host=NONE no_create= nonopt=NONE no_recursion= prefix=NONE program_prefix=NONE program_suffix=NONE program_transform_name=s,x,x, silent= site= srcdir= target=NONE verbose= x_includes=NONE x_libraries=NONE bindir='${exec_prefix}/bin' sbindir='${exec_prefix}/sbin' libexecdir='${exec_prefix}/libexec' datadir='${prefix}/share' sysconfdir='${prefix}/etc' sharedstatedir='${prefix}/com' localstatedir='${prefix}/var' libdir='${exec_prefix}/lib' includedir='${prefix}/include' oldincludedir='/usr/include' infodir='${prefix}/info' mandir='${prefix}/man' # Initialize some other variables. subdirs= MFLAGS= MAKEFLAGS= # Maximum number of lines to put in a shell here document. ac_max_here_lines=12 ac_prev= for ac_option do # If the previous option needs an argument, assign it. if test -n "$ac_prev"; then eval "$ac_prev=\$ac_option" ac_prev= continue fi case "$ac_option" in -*=*) ac_optarg=`echo "$ac_option" | sed 's/[-_a-zA-Z0-9]*=//'` ;; *) ac_optarg= ;; esac # Accept the important Cygnus configure options, so we can diagnose typos. case "$ac_option" in -bindir | --bindir | --bindi | --bind | --bin | --bi) ac_prev=bindir ;; -bindir=* | --bindir=* | --bindi=* | --bind=* | --bin=* | --bi=*) bindir="$ac_optarg" ;; -build | --build | --buil | --bui | --bu) ac_prev=build ;; -build=* | --build=* | --buil=* | --bui=* | --bu=*) build="$ac_optarg" ;; -cache-file | --cache-file | --cache-fil | --cache-fi \ | --cache-f | --cache- | --cache | --cach | --cac | --ca | --c) ac_prev=cache_file ;; -cache-file=* | --cache-file=* | --cache-fil=* | --cache-fi=* \ | --cache-f=* | --cache-=* | --cache=* | --cach=* | --cac=* | --ca=* | --c=*) cache_file="$ac_optarg" ;; -datadir | --datadir | --datadi | --datad | --data | --dat | --da) ac_prev=datadir ;; -datadir=* | --datadir=* | --datadi=* | --datad=* | --data=* | --dat=* \ | --da=*) datadir="$ac_optarg" ;; -disable-* | --disable-*) ac_feature=`echo $ac_option|sed -e 's/-*disable-//'` # Reject names that are not valid shell variable names. if test -n "`echo $ac_feature| sed 's/[-a-zA-Z0-9_]//g'`"; then { echo "configure: error: $ac_feature: invalid feature name" 1>&2; exit 1; } fi ac_feature=`echo $ac_feature| sed 's/-/_/g'` eval "enable_${ac_feature}=no" ;; -enable-* | --enable-*) ac_feature=`echo $ac_option|sed -e 's/-*enable-//' -e 's/=.*//'` # Reject names that are not valid shell variable names. if test -n "`echo $ac_feature| sed 's/[-_a-zA-Z0-9]//g'`"; then { echo "configure: error: $ac_feature: invalid feature name" 1>&2; exit 1; } fi ac_feature=`echo $ac_feature| sed 's/-/_/g'` case "$ac_option" in *=*) ;; *) ac_optarg=yes ;; esac eval "enable_${ac_feature}='$ac_optarg'" ;; -exec-prefix | --exec_prefix | --exec-prefix | --exec-prefi \ | --exec-pref | --exec-pre | --exec-pr | --exec-p | --exec- \ | --exec | --exe | --ex) ac_prev=exec_prefix ;; -exec-prefix=* | --exec_prefix=* | --exec-prefix=* | --exec-prefi=* \ | --exec-pref=* | --exec-pre=* | --exec-pr=* | --exec-p=* | --exec-=* \ | --exec=* | --exe=* | --ex=*) exec_prefix="$ac_optarg" ;; -gas | --gas | --ga | --g) # Obsolete; use --with-gas. with_gas=yes ;; -help | --help | --hel | --he) # Omit some internal or obsolete options to make the list less imposing. # This message is too long to be a string in the A/UX 3.1 sh. cat << EOF Usage: configure [options] [host] Options: [defaults in brackets after descriptions] Configuration: --cache-file=FILE cache test results in FILE --help print this message --no-create do not create output files --quiet, --silent do not print \`checking...' messages --version print the version of autoconf that created configure Directory and file names: --prefix=PREFIX install architecture-independent files in PREFIX [$ac_default_prefix] --exec-prefix=EPREFIX install architecture-dependent files in EPREFIX [same as prefix] --bindir=DIR user executables in DIR [EPREFIX/bin] --sbindir=DIR system admin executables in DIR [EPREFIX/sbin] --libexecdir=DIR program executables in DIR [EPREFIX/libexec] --datadir=DIR read-only architecture-independent data in DIR [PREFIX/share] --sysconfdir=DIR read-only single-machine data in DIR [PREFIX/etc] --sharedstatedir=DIR modifiable architecture-independent data in DIR [PREFIX/com] --localstatedir=DIR modifiable single-machine data in DIR [PREFIX/var] --libdir=DIR object code libraries in DIR [EPREFIX/lib] --includedir=DIR C header files in DIR [PREFIX/include] --oldincludedir=DIR C header files for non-gcc in DIR [/usr/include] --infodir=DIR info documentation in DIR [PREFIX/info] --mandir=DIR man documentation in DIR [PREFIX/man] --srcdir=DIR find the sources in DIR [configure dir or ..] --program-prefix=PREFIX prepend PREFIX to installed program names --program-suffix=SUFFIX append SUFFIX to installed program names --program-transform-name=PROGRAM run sed PROGRAM on installed program names EOF cat << EOF Host type: --build=BUILD configure for building on BUILD [BUILD=HOST] --host=HOST configure for HOST [guessed] --target=TARGET configure for TARGET [TARGET=HOST] Features and packages: --disable-FEATURE do not include FEATURE (same as --enable-FEATURE=no) --enable-FEATURE[=ARG] include FEATURE [ARG=yes] --with-PACKAGE[=ARG] use PACKAGE [ARG=yes] --without-PACKAGE do not use PACKAGE (same as --with-PACKAGE=no) --x-includes=DIR X include files are in DIR --x-libraries=DIR X library files are in DIR EOF if test -n "$ac_help"; then echo "--enable and --with options recognized:$ac_help" fi exit 0 ;; -host | --host | --hos | --ho) ac_prev=host ;; -host=* | --host=* | --hos=* | --ho=*) host="$ac_optarg" ;; -includedir | --includedir | --includedi | --included | --include \ | --includ | --inclu | --incl | --inc) ac_prev=includedir ;; -includedir=* | --includedir=* | --includedi=* | --included=* | --include=* \ | --includ=* | --inclu=* | --incl=* | --inc=*) includedir="$ac_optarg" ;; -infodir | --infodir | --infodi | --infod | --info | --inf) ac_prev=infodir ;; -infodir=* | --infodir=* | --infodi=* | --infod=* | --info=* | --inf=*) infodir="$ac_optarg" ;; -libdir | --libdir | --libdi | --libd) ac_prev=libdir ;; -libdir=* | --libdir=* | --libdi=* | --libd=*) libdir="$ac_optarg" ;; -libexecdir | --libexecdir | --libexecdi | --libexecd | --libexec \ | --libexe | --libex | --libe) ac_prev=libexecdir ;; -libexecdir=* | --libexecdir=* | --libexecdi=* | --libexecd=* | --libexec=* \ | --libexe=* | --libex=* | --libe=*) libexecdir="$ac_optarg" ;; -localstatedir | --localstatedir | --localstatedi | --localstated \ | --localstate | --localstat | --localsta | --localst \ | --locals | --local | --loca | --loc | --lo) ac_prev=localstatedir ;; -localstatedir=* | --localstatedir=* | --localstatedi=* | --localstated=* \ | --localstate=* | --localstat=* | --localsta=* | --localst=* \ | --locals=* | --local=* | --loca=* | --loc=* | --lo=*) localstatedir="$ac_optarg" ;; -mandir | --mandir | --mandi | --mand | --man | --ma | --m) ac_prev=mandir ;; -mandir=* | --mandir=* | --mandi=* | --mand=* | --man=* | --ma=* | --m=*) mandir="$ac_optarg" ;; -nfp | --nfp | --nf) # Obsolete; use --without-fp. with_fp=no ;; -no-create | --no-create | --no-creat | --no-crea | --no-cre \ | --no-cr | --no-c) no_create=yes ;; -no-recursion | --no-recursion | --no-recursio | --no-recursi \ | --no-recurs | --no-recur | --no-recu | --no-rec | --no-re | --no-r) no_recursion=yes ;; -oldincludedir | --oldincludedir | --oldincludedi | --oldincluded \ | --oldinclude | --oldinclud | --oldinclu | --oldincl | --oldinc \ | --oldin | --oldi | --old | --ol | --o) ac_prev=oldincludedir ;; -oldincludedir=* | --oldincludedir=* | --oldincludedi=* | --oldincluded=* \ | --oldinclude=* | --oldinclud=* | --oldinclu=* | --oldincl=* | --oldinc=* \ | --oldin=* | --oldi=* | --old=* | --ol=* | --o=*) oldincludedir="$ac_optarg" ;; -prefix | --prefix | --prefi | --pref | --pre | --pr | --p) ac_prev=prefix ;; -prefix=* | --prefix=* | --prefi=* | --pref=* | --pre=* | --pr=* | --p=*) prefix="$ac_optarg" ;; -program-prefix | --program-prefix | --program-prefi | --program-pref \ | --program-pre | --program-pr | --program-p) ac_prev=program_prefix ;; -program-prefix=* | --program-prefix=* | --program-prefi=* \ | --program-pref=* | --program-pre=* | --program-pr=* | --program-p=*) program_prefix="$ac_optarg" ;; -program-suffix | --program-suffix | --program-suffi | --program-suff \ | --program-suf | --program-su | --program-s) ac_prev=program_suffix ;; -program-suffix=* | --program-suffix=* | --program-suffi=* \ | --program-suff=* | --program-suf=* | --program-su=* | --program-s=*) program_suffix="$ac_optarg" ;; -program-transform-name | --program-transform-name \ | --program-transform-nam | --program-transform-na \ | --program-transform-n | --program-transform- \ | --program-transform | --program-transfor \ | --program-transfo | --program-transf \ | --program-trans | --program-tran \ | --progr-tra | --program-tr | --program-t) ac_prev=program_transform_name ;; -program-transform-name=* | --program-transform-name=* \ | --program-transform-nam=* | --program-transform-na=* \ | --program-transform-n=* | --program-transform-=* \ | --program-transform=* | --program-transfor=* \ | --program-transfo=* | --program-transf=* \ | --program-trans=* | --program-tran=* \ | --progr-tra=* | --program-tr=* | --program-t=*) program_transform_name="$ac_optarg" ;; -q | -quiet | --quiet | --quie | --qui | --qu | --q \ | -silent | --silent | --silen | --sile | --sil) silent=yes ;; -sbindir | --sbindir | --sbindi | --sbind | --sbin | --sbi | --sb) ac_prev=sbindir ;; -sbindir=* | --sbindir=* | --sbindi=* | --sbind=* | --sbin=* \ | --sbi=* | --sb=*) sbindir="$ac_optarg" ;; -sharedstatedir | --sharedstatedir | --sharedstatedi \ | --sharedstated | --sharedstate | --sharedstat | --sharedsta \ | --sharedst | --shareds | --shared | --share | --shar \ | --sha | --sh) ac_prev=sharedstatedir ;; -sharedstatedir=* | --sharedstatedir=* | --sharedstatedi=* \ | --sharedstated=* | --sharedstate=* | --sharedstat=* | --sharedsta=* \ | --sharedst=* | --shareds=* | --shared=* | --share=* | --shar=* \ | --sha=* | --sh=*) sharedstatedir="$ac_optarg" ;; -site | --site | --sit) ac_prev=site ;; -site=* | --site=* | --sit=*) site="$ac_optarg" ;; -srcdir | --srcdir | --srcdi | --srcd | --src | --sr) ac_prev=srcdir ;; -srcdir=* | --srcdir=* | --srcdi=* | --srcd=* | --src=* | --sr=*) srcdir="$ac_optarg" ;; -sysconfdir | --sysconfdir | --sysconfdi | --sysconfd | --sysconf \ | --syscon | --sysco | --sysc | --sys | --sy) ac_prev=sysconfdir ;; -sysconfdir=* | --sysconfdir=* | --sysconfdi=* | --sysconfd=* | --sysconf=* \ | --syscon=* | --sysco=* | --sysc=* | --sys=* | --sy=*) sysconfdir="$ac_optarg" ;; -target | --target | --targe | --targ | --tar | --ta | --t) ac_prev=target ;; -target=* | --target=* | --targe=* | --targ=* | --tar=* | --ta=* | --t=*) target="$ac_optarg" ;; -v | -verbose | --verbose | --verbos | --verbo | --verb) verbose=yes ;; -version | --version | --versio | --versi | --vers) echo "configure generated by autoconf version 2.12" exit 0 ;; -with-* | --with-*) ac_package=`echo $ac_option|sed -e 's/-*with-//' -e 's/=.*//'` # Reject names that are not valid shell variable names. if test -n "`echo $ac_package| sed 's/[-_a-zA-Z0-9]//g'`"; then { echo "configure: error: $ac_package: invalid package name" 1>&2; exit 1; } fi ac_package=`echo $ac_package| sed 's/-/_/g'` case "$ac_option" in *=*) ;; *) ac_optarg=yes ;; esac eval "with_${ac_package}='$ac_optarg'" ;; -without-* | --without-*) ac_package=`echo $ac_option|sed -e 's/-*without-//'` # Reject names that are not valid shell variable names. if test -n "`echo $ac_package| sed 's/[-a-zA-Z0-9_]//g'`"; then { echo "configure: error: $ac_package: invalid package name" 1>&2; exit 1; } fi ac_package=`echo $ac_package| sed 's/-/_/g'` eval "with_${ac_package}=no" ;; --x) # Obsolete; use --with-x. with_x=yes ;; -x-includes | --x-includes | --x-include | --x-includ | --x-inclu \ | --x-incl | --x-inc | --x-in | --x-i) ac_prev=x_includes ;; -x-includes=* | --x-includes=* | --x-include=* | --x-includ=* | --x-inclu=* \ | --x-incl=* | --x-inc=* | --x-in=* | --x-i=*) x_includes="$ac_optarg" ;; -x-libraries | --x-libraries | --x-librarie | --x-librari \ | --x-librar | --x-libra | --x-libr | --x-lib | --x-li | --x-l) ac_prev=x_libraries ;; -x-libraries=* | --x-libraries=* | --x-librarie=* | --x-librari=* \ | --x-librar=* | --x-libra=* | --x-libr=* | --x-lib=* | --x-li=* | --x-l=*) x_libraries="$ac_optarg" ;; -*) { echo "configure: error: $ac_option: invalid option; use --help to show usage" 1>&2; exit 1; } ;; *) if test -n "`echo $ac_option| sed 's/[-a-z0-9.]//g'`"; then echo "configure: warning: $ac_option: invalid host type" 1>&2 fi if test "x$nonopt" != xNONE; then { echo "configure: error: can only configure for one host and one target at a time" 1>&2; exit 1; } fi nonopt="$ac_option" ;; esac done if test -n "$ac_prev"; then { echo "configure: error: missing argument to --`echo $ac_prev | sed 's/_/-/g'`" 1>&2; exit 1; } fi trap 'rm -fr conftest* confdefs* core core.* *.core $ac_clean_files; exit 1' 1 2 15 # File descriptor usage: # 0 standard input # 1 file creation # 2 errors and warnings # 3 some systems may open it to /dev/tty # 4 used on the Kubota Titan # 6 checking for... messages and results # 5 compiler messages saved in config.log if test "$silent" = yes; then exec 6>/dev/null else exec 6>&1 fi exec 5>./config.log echo "\ This file contains any messages produced by compilers while running configure, to aid debugging if configure makes a mistake. " 1>&5 # Strip out --no-create and --no-recursion so they do not pile up. # Also quote any args containing shell metacharacters. ac_configure_args= for ac_arg do case "$ac_arg" in -no-create | --no-create | --no-creat | --no-crea | --no-cre \ | --no-cr | --no-c) ;; -no-recursion | --no-recursion | --no-recursio | --no-recursi \ | --no-recurs | --no-recur | --no-recu | --no-rec | --no-re | --no-r) ;; *" "*|*" "*|*[\[\]\~\#\$\^\&\*\(\)\{\}\\\|\;\<\>\?]*) ac_configure_args="$ac_configure_args '$ac_arg'" ;; *) ac_configure_args="$ac_configure_args $ac_arg" ;; esac done # NLS nuisances. # Only set these to C if already set. These must not be set unconditionally # because not all systems understand e.g. LANG=C (notably SCO). # Fixing LC_MESSAGES prevents Solaris sh from translating var values in `set'! # Non-C LC_CTYPE values break the ctype check. if test "${LANG+set}" = set; then LANG=C; export LANG; fi if test "${LC_ALL+set}" = set; then LC_ALL=C; export LC_ALL; fi if test "${LC_MESSAGES+set}" = set; then LC_MESSAGES=C; export LC_MESSAGES; fi if test "${LC_CTYPE+set}" = set; then LC_CTYPE=C; export LC_CTYPE; fi # confdefs.h avoids OS command line length limits that DEFS can exceed. rm -rf conftest* confdefs.h # AIX cpp loses on an empty file, so make sure it contains at least a newline. echo > confdefs.h # A filename unique to this package, relative to the directory that # configure is in, which we can look for to find out if srcdir is correct. ac_unique_file=ftpmirror # Find the source files, if location was not specified. if test -z "$srcdir"; then ac_srcdir_defaulted=yes # Try the directory containing this script, then its parent. ac_prog=$0 ac_confdir=`echo $ac_prog|sed 's%/[^/][^/]*$%%'` test "x$ac_confdir" = "x$ac_prog" && ac_confdir=. srcdir=$ac_confdir if test ! -r $srcdir/$ac_unique_file; then srcdir=.. fi else ac_srcdir_defaulted=no fi if test ! -r $srcdir/$ac_unique_file; then if test "$ac_srcdir_defaulted" = yes; then { echo "configure: error: can not find sources in $ac_confdir or .." 1>&2; exit 1; } else { echo "configure: error: can not find sources in $srcdir" 1>&2; exit 1; } fi fi srcdir=`echo "${srcdir}" | sed 's%\([^/]\)/*$%\1%'` # Prefer explicitly selected file to automatically selected ones. if test -z "$CONFIG_SITE"; then if test "x$prefix" != xNONE; then CONFIG_SITE="$prefix/share/config.site $prefix/etc/config.site" else CONFIG_SITE="$ac_default_prefix/share/config.site $ac_default_prefix/etc/config.site" fi fi for ac_site_file in $CONFIG_SITE; do if test -r "$ac_site_file"; then echo "loading site script $ac_site_file" . "$ac_site_file" fi done if test -r "$cache_file"; then echo "loading cache $cache_file" . $cache_file else echo "creating cache $cache_file" > $cache_file fi ac_ext=c # CFLAGS is not in ac_cpp because -g, -O, etc. are not valid cpp options. ac_cpp='$CPP $CPPFLAGS' ac_compile='${CC-cc} -c $CFLAGS $CPPFLAGS conftest.$ac_ext 1>&5' ac_link='${CC-cc} -o conftest $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS 1>&5' cross_compiling=$ac_cv_prog_cc_cross if (echo "testing\c"; echo 1,2,3) | grep c >/dev/null; then # Stardent Vistra SVR4 grep lacks -e, says ghazi@caip.rutgers.edu. if (echo -n testing; echo 1,2,3) | sed s/-n/xn/ | grep xn >/dev/null; then ac_n= ac_c=' ' ac_t=' ' else ac_n=-n ac_c= ac_t= fi else ac_n= ac_c='\c' ac_t= fi ac_aux_dir= for ac_dir in $srcdir $srcdir/.. $srcdir/../..; do if test -f $ac_dir/install-sh; then ac_aux_dir=$ac_dir ac_install_sh="$ac_aux_dir/install-sh -c" break elif test -f $ac_dir/install.sh; then ac_aux_dir=$ac_dir ac_install_sh="$ac_aux_dir/install.sh -c" break fi done if test -z "$ac_aux_dir"; then { echo "configure: error: can not find install-sh or install.sh in $srcdir $srcdir/.. $srcdir/../.." 1>&2; exit 1; } fi ac_config_guess=$ac_aux_dir/config.guess ac_config_sub=$ac_aux_dir/config.sub ac_configure=$ac_aux_dir/configure # This should be Cygnus configure. # Find a good install program. We prefer a C program (faster), # so one script is as good as another. But avoid the broken or # incompatible versions: # SysV /etc/install, /usr/sbin/install # SunOS /usr/etc/install # IRIX /sbin/install # AIX /bin/install # AFS /usr/afsws/bin/install, which mishandles nonexistent args # SVR4 /usr/ucb/install, which tries to use the nonexistent group "staff" # ./install, which can be erroneously created by make from ./install.sh. echo $ac_n "checking for a BSD compatible install""... $ac_c" 1>&6 echo "configure:553: checking for a BSD compatible install" >&5 if test -z "$INSTALL"; then if eval "test \"`echo '$''{'ac_cv_path_install'+set}'`\" = set"; then echo $ac_n "(cached) $ac_c" 1>&6 else IFS="${IFS= }"; ac_save_IFS="$IFS"; IFS="${IFS}:" for ac_dir in $PATH; do # Account for people who put trailing slashes in PATH elements. case "$ac_dir/" in /|./|.//|/etc/*|/usr/sbin/*|/usr/etc/*|/sbin/*|/usr/afsws/bin/*|/usr/ucb/*) ;; *) # OSF1 and SCO ODT 3.0 have their own names for install. for ac_prog in ginstall installbsd scoinst install; do if test -f $ac_dir/$ac_prog; then if test $ac_prog = install && grep dspmsg $ac_dir/$ac_prog >/dev/null 2>&1; then # AIX install. It has an incompatible calling convention. # OSF/1 installbsd also uses dspmsg, but is usable. : else ac_cv_path_install="$ac_dir/$ac_prog -c" break 2 fi fi done ;; esac done IFS="$ac_save_IFS" fi if test "${ac_cv_path_install+set}" = set; then INSTALL="$ac_cv_path_install" else # As a last resort, use the slow shell script. We don't cache a # path for INSTALL within a source directory, because that will # break other packages using the cache if that directory is # removed, or if the path is relative. INSTALL="$ac_install_sh" fi fi echo "$ac_t""$INSTALL" 1>&6 # Use test -z because SunOS4 sh mishandles braces in ${var-val}. # It thinks the first close brace ends the variable substitution. test -z "$INSTALL_PROGRAM" && INSTALL_PROGRAM='${INSTALL}' test -z "$INSTALL_DATA" && INSTALL_DATA='${INSTALL} -m 644' for ac_prog in perl5 perl do # Extract the first word of "$ac_prog", so it can be a program name with args. set dummy $ac_prog; ac_word=$2 echo $ac_n "checking for $ac_word""... $ac_c" 1>&6 echo "configure:608: checking for $ac_word" >&5 if eval "test \"`echo '$''{'ac_cv_path_PERL'+set}'`\" = set"; then echo $ac_n "(cached) $ac_c" 1>&6 else case "$PERL" in /*) ac_cv_path_PERL="$PERL" # Let the user override the test with a path. ;; *) IFS="${IFS= }"; ac_save_ifs="$IFS"; IFS="${IFS}:" for ac_dir in $PATH; do test -z "$ac_dir" && ac_dir=. if test -f $ac_dir/$ac_word; then ac_cv_path_PERL="$ac_dir/$ac_word" break fi done IFS="$ac_save_ifs" ;; esac fi PERL="$ac_cv_path_PERL" if test -n "$PERL"; then echo "$ac_t""$PERL" 1>&6 else echo "$ac_t""no" 1>&6 fi test -n "$PERL" && break done test -n "$PERL" || PERL="not found" if test "x$PERL" != "xnot found" && \ $PERL -e 'exit ($] < 5.004 ? 1 : 0)'; then : # good else { echo "configure: error: perl version 5.004 or lator was required." 1>&2; exit 1; } fi trap '' 1 2 15 cat > confcache <<\EOF # This file is a shell script that caches the results of configure # tests run on this system so they can be shared between configure # scripts and configure runs. It is not useful on other systems. # If it contains results you don't want to keep, you may remove or edit it. # # By default, configure uses ./config.cache as the cache file, # creating it if it does not exist already. You can give configure # the --cache-file=FILE option to use a different cache file; that is # what configure does when it calls configure scripts in # subdirectories, so they share the cache. # Giving --cache-file=/dev/null disables caching, for debugging configure. # config.status only pays attention to the cache file if you give it the # --recheck option to rerun configure. # EOF # The following way of writing the cache mishandles newlines in values, # but we know of no workaround that is simple, portable, and efficient. # So, don't put newlines in cache variables' values. # Ultrix sh set writes to stderr and can't be redirected directly, # and sets the high bit in the cache file unless we assign to the vars. (set) 2>&1 | case `(ac_space=' '; set) 2>&1` in *ac_space=\ *) # `set' does not quote correctly, so add quotes (double-quote substitution # turns \\\\ into \\, and sed turns \\ into \). sed -n \ -e "s/'/'\\\\''/g" \ -e "s/^\\([a-zA-Z0-9_]*_cv_[a-zA-Z0-9_]*\\)=\\(.*\\)/\\1=\${\\1='\\2'}/p" ;; *) # `set' quotes correctly as required by POSIX, so do not add quotes. sed -n -e 's/^\([a-zA-Z0-9_]*_cv_[a-zA-Z0-9_]*\)=\(.*\)/\1=${\1=\2}/p' ;; esac >> confcache if cmp -s $cache_file confcache; then : else if test -w $cache_file; then echo "updating cache $cache_file" cat confcache > $cache_file else echo "not updating unwritable cache $cache_file" fi fi rm -f confcache trap 'rm -fr conftest* confdefs* core core.* *.core $ac_clean_files; exit 1' 1 2 15 test "x$prefix" = xNONE && prefix=$ac_default_prefix # Let make expand exec_prefix. test "x$exec_prefix" = xNONE && exec_prefix='${prefix}' # Any assignment to VPATH causes Sun make to only execute # the first set of double-colon rules, so remove it if not needed. # If there is a colon in the path, we need to keep it. if test "x$srcdir" = x.; then ac_vpsub='/^[ ]*VPATH[ ]*=[^:]*$/d' fi trap 'rm -f $CONFIG_STATUS conftest*; exit 1' 1 2 15 # Transform confdefs.h into DEFS. # Protect against shell expansion while executing Makefile rules. # Protect against Makefile macro expansion. cat > conftest.defs <<\EOF s%#define \([A-Za-z_][A-Za-z0-9_]*\) *\(.*\)%-D\1=\2%g s%[ `~#$^&*(){}\\|;'"<>?]%\\&%g s%\[%\\&%g s%\]%\\&%g s%\$%$$%g EOF DEFS=`sed -f conftest.defs confdefs.h | tr '\012' ' '` rm -f conftest.defs # Without the "./", some shells look in PATH for config.status. : ${CONFIG_STATUS=./config.status} echo creating $CONFIG_STATUS rm -f $CONFIG_STATUS cat > $CONFIG_STATUS </dev/null | sed 1q`: # # $0 $ac_configure_args # # Compiler output produced by configure, useful for debugging # configure, is in ./config.log if it exists. ac_cs_usage="Usage: $CONFIG_STATUS [--recheck] [--version] [--help]" for ac_option do case "\$ac_option" in -recheck | --recheck | --rechec | --reche | --rech | --rec | --re | --r) echo "running \${CONFIG_SHELL-/bin/sh} $0 $ac_configure_args --no-create --no-recursion" exec \${CONFIG_SHELL-/bin/sh} $0 $ac_configure_args --no-create --no-recursion ;; -version | --version | --versio | --versi | --vers | --ver | --ve | --v) echo "$CONFIG_STATUS generated by autoconf version 2.12" exit 0 ;; -help | --help | --hel | --he | --h) echo "\$ac_cs_usage"; exit 0 ;; *) echo "\$ac_cs_usage"; exit 1 ;; esac done ac_given_srcdir=$srcdir ac_given_INSTALL="$INSTALL" trap 'rm -fr `echo "Makefile" | sed "s/:[^ ]*//g"` conftest*; exit 1' 1 2 15 EOF cat >> $CONFIG_STATUS < conftest.subs <<\\CEOF $ac_vpsub $extrasub s%@CFLAGS@%$CFLAGS%g s%@CPPFLAGS@%$CPPFLAGS%g s%@CXXFLAGS@%$CXXFLAGS%g s%@DEFS@%$DEFS%g s%@LDFLAGS@%$LDFLAGS%g s%@LIBS@%$LIBS%g s%@exec_prefix@%$exec_prefix%g s%@prefix@%$prefix%g s%@program_transform_name@%$program_transform_name%g s%@bindir@%$bindir%g s%@sbindir@%$sbindir%g s%@libexecdir@%$libexecdir%g s%@datadir@%$datadir%g s%@sysconfdir@%$sysconfdir%g s%@sharedstatedir@%$sharedstatedir%g s%@localstatedir@%$localstatedir%g s%@libdir@%$libdir%g s%@includedir@%$includedir%g s%@oldincludedir@%$oldincludedir%g s%@infodir@%$infodir%g s%@mandir@%$mandir%g s%@INSTALL_PROGRAM@%$INSTALL_PROGRAM%g s%@INSTALL_DATA@%$INSTALL_DATA%g s%@PERL@%$PERL%g CEOF EOF cat >> $CONFIG_STATUS <<\EOF # Split the substitutions into bite-sized pieces for seds with # small command number limits, like on Digital OSF/1 and HP-UX. ac_max_sed_cmds=90 # Maximum number of lines to put in a sed script. ac_file=1 # Number of current file. ac_beg=1 # First line for current file. ac_end=$ac_max_sed_cmds # Line after last line for current file. ac_more_lines=: ac_sed_cmds="" while $ac_more_lines; do if test $ac_beg -gt 1; then sed "1,${ac_beg}d; ${ac_end}q" conftest.subs > conftest.s$ac_file else sed "${ac_end}q" conftest.subs > conftest.s$ac_file fi if test ! -s conftest.s$ac_file; then ac_more_lines=false rm -f conftest.s$ac_file else if test -z "$ac_sed_cmds"; then ac_sed_cmds="sed -f conftest.s$ac_file" else ac_sed_cmds="$ac_sed_cmds | sed -f conftest.s$ac_file" fi ac_file=`expr $ac_file + 1` ac_beg=$ac_end ac_end=`expr $ac_end + $ac_max_sed_cmds` fi done if test -z "$ac_sed_cmds"; then ac_sed_cmds=cat fi EOF cat >> $CONFIG_STATUS <> $CONFIG_STATUS <<\EOF for ac_file in .. $CONFIG_FILES; do if test "x$ac_file" != x..; then # Support "outfile[:infile[:infile...]]", defaulting infile="outfile.in". case "$ac_file" in *:*) ac_file_in=`echo "$ac_file"|sed 's%[^:]*:%%'` ac_file=`echo "$ac_file"|sed 's%:.*%%'` ;; *) ac_file_in="${ac_file}.in" ;; esac # Adjust a relative srcdir, top_srcdir, and INSTALL for subdirectories. # Remove last slash and all that follows it. Not all systems have dirname. ac_dir=`echo $ac_file|sed 's%/[^/][^/]*$%%'` if test "$ac_dir" != "$ac_file" && test "$ac_dir" != .; then # The file is in a subdirectory. test ! -d "$ac_dir" && mkdir "$ac_dir" ac_dir_suffix="/`echo $ac_dir|sed 's%^\./%%'`" # A "../" for each directory in $ac_dir_suffix. ac_dots=`echo $ac_dir_suffix|sed 's%/[^/]*%../%g'` else ac_dir_suffix= ac_dots= fi case "$ac_given_srcdir" in .) srcdir=. if test -z "$ac_dots"; then top_srcdir=. else top_srcdir=`echo $ac_dots|sed 's%/$%%'`; fi ;; /*) srcdir="$ac_given_srcdir$ac_dir_suffix"; top_srcdir="$ac_given_srcdir" ;; *) # Relative path. srcdir="$ac_dots$ac_given_srcdir$ac_dir_suffix" top_srcdir="$ac_dots$ac_given_srcdir" ;; esac case "$ac_given_INSTALL" in [/$]*) INSTALL="$ac_given_INSTALL" ;; *) INSTALL="$ac_dots$ac_given_INSTALL" ;; esac echo creating "$ac_file" rm -f "$ac_file" configure_input="Generated automatically from `echo $ac_file_in|sed 's%.*/%%'` by configure." case "$ac_file" in *Makefile*) ac_comsub="1i\\ # $configure_input" ;; *) ac_comsub= ;; esac ac_file_inputs=`echo $ac_file_in|sed -e "s%^%$ac_given_srcdir/%" -e "s%:% $ac_given_srcdir/%g"` sed -e "$ac_comsub s%@configure_input@%$configure_input%g s%@srcdir@%$srcdir%g s%@top_srcdir@%$top_srcdir%g s%@INSTALL@%$INSTALL%g " $ac_file_inputs | (eval "$ac_sed_cmds") > $ac_file fi; done rm -f conftest.s* EOF cat >> $CONFIG_STATUS <> $CONFIG_STATUS <<\EOF exit 0 EOF chmod +x $CONFIG_STATUS rm -fr confdefs* $ac_clean_files test "$no_create" = yes || ${CONFIG_SHELL-/bin/sh} $CONFIG_STATUS || exit 1 ftpmirror-1.96/configure.in100644 1751 1750 1412 6575114537 14252 0ustar ikuouserdnl Process this file with autoconf to produce a configure script. AC_INIT(ftpmirror) dnl AC_CONFIG_HEADER(config.h) dnl AC_PREFIX_DEFAULT(/usr/local/ftpmirror) dnl Checks for programs. dnl AC_PROG_CC dnl AC_PROG_RANLIB dnl AC_PATH_PROG(MAKEDEPEND, makedepend makedep, makedepend) AC_PROG_INSTALL dnl We require perl 5.004 or later. AC_PATH_PROGS(PERL, perl5 perl, not found) if test "x$PERL" != "xnot found" && \ $PERL -e 'exit ($] < 5.004 ? 1 : 0)'; then : # good else AC_MSG_ERROR(perl version 5.004 or lator was required.) fi dnl Checks for libraries. dnl AC_CHECK_LIB(md, MD5File) dnl Checks for header files. dnl Checks for typedefs, structures, and compiler characteristics. dnl Checks for library functions. dnl AC_CONFIG_SUBDIRS(src) AC_OUTPUT(Makefile) ftpmirror-1.96/farm100644 1751 1750 2445 6404506405 12606 0ustar ikuouser#!/usr/local/bin/perl use strict; use vars qw($opt_D $opt_c $opt_l $opt_u $opt_d $opt_o $opt_v); use Getopt::Std; use Fan::Farm; use Fan::Scan; BEGIN { $| = 1; } getopts("Dludo:v") or die("Usage: $0 <-c|-u|-d|-l> [-v] [-o file]\n"); ($opt_c + $opt_l + $opt_u + $opt_d == 1) or die("$0: just one of -c/-l/-u/-d must be given.\n"); $Fan::Farm::LOG = 6 if $opt_v; $Fan::Farm::LOG = 7 if $opt_D; $opt_o = \*STDOUT if $opt_o eq ''; if ($opt_c) { my $dir = shift; -d $dir or die("database directory must be given.\n"); Fan::Farm::scan_listup($opt_o, $dir); } elsif ($opt_u) { my $base = shift; -f $base or die("base index must be given.\n"); @ARGV > 0 or die("no patch file specified.\n"); Fan::Farm::scan_update($opt_o, $base, @ARGV); } elsif ($opt_d) { my $old = shift; my $new = shift; -f $old or die("old index must exist.\n"); -f $new or die("new index must exist.\n"); Fan::Farm::scan_differ($opt_o, $old, $new); } elsif ($opt_l) { my $index = shift; -f $index or die("index file must be given.\n"); my $scan = Fan::Scan->new( scan_type => 'INDEX', scan_index => $index, ); ref($scan) or die("can't create scan object.\n"); my $x; while (defined($x = $scan->get)) { next if $x->type eq '.' || $x->type eq 'U'; print $x->path."\n"; } } else { die("I don't know what to do\n"); } ftpmirror-1.96/ftpmirror100755 1751 1750 6016 7012375734 13713 0ustar ikuouser#!/usr/local/bin/perl ;# ;# Copyright (c) 1995-1999 ;# 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: ftpmirror,v 1.15 1999/11/10 23:12:28 ikuo Exp $ ;# use strict; use vars qw($VERSION $LOG $program); ;# modules use Fan; ;# this is an alpha version. $VERSION = '0.15'; $LOG = 5; ;# this program name $program = $0 =~ m|([^/]+)$|; ;# full setup of Fan module. Fan->full_setup(\@ARGV) or die("can't initialize Fan library.\n"); ;# parsing arguments. while (@ARGV) { my $name = shift; my $p = Fan->find_archive($name); unless (ref($p) && $p->isa('Fan')) { warn("$name: can't find archive, skipped.\n"), next; } # check first unless ($p->check) { warn("$name: check failure.\n"), next; } # my $todo; if (!defined($todo = $p->todo)) { $todo = $program; } # we use ``eval'' to do real work. # so, we can abort anywhere in subroutine. if ($todo eq 'update-master') { eval { $p->update_master }; } elsif ($todo eq 'scan-local') { eval { $p->scan_local }; } elsif ($todo eq 'scan-remote') { eval { $p->scan_remote }; } elsif ($todo eq 'mkdirinfo') { eval { $p->mkdirinfo }; } elsif ($todo eq 'synch-remote') { eval { $p->step_synch }; } elsif ($todo eq 'step-mirror') { eval { $p->run_step_mirror }; } else { # remaining cases including "ftpmirror" eval { $p->run_full_mirror }; } if ($@) { warn("eval($todo):\n$@"); } } ;# exit; ;# sub show_usage { use Fan::Usage; if (@_) { my $sig = shift; warn("* signal $sig detected.\n"); } my $u = getrusage; $u->dump; undef $u; 1; } =head1 NAME ftpmirror - Mirror directory hiearachy via FTP (or HTTP). =head1 SYNOPSIS C =head1 DESCRIPTION Ftpmirror mirrors directory hiearachy via FTP (or HTTP). =head1 AUTHER Ikuo Nakagawa, Oct, 1999 =item =cut ftpmirror-1.96/ftpmirror.cf-sample100644 1751 1750 5640 6607647547 15575 0ustar ikuouser# login name for ftp session. # ftp-user = anonymous # password must be e-mail address. # ftp-pass = ftp-admin@your.domain.name # if no listing method required, http proxy can be used. # http-proxy = proxy.your.net.com # do you like passive mode for data transfer? # ftp-passive = yes # to force to get mtime (by MDTM ftp command) uncomment this. # ftp-force-mtime = yes # uncomment the next line to see ftp statistics report. # ftp-stats = yes # to list up all available files, uncomment the next line. # log-mask = main=6 # if you'd like to unlink no file, set unlink to false. # unlink = no # by default, $TMPDIR or "/tmp" is used for the temporary directory. # temp-directory = /tmp # generic directories (%s will be replaced with package name). remote-directory = /pub/%s local-directory = ~ftp/pub/%s # to use FTP Archive Revision Manager, setup db directories. # for master servers: # master-db-directory = ~ftp/db/%s # and for slave server: # remote-db-directory = /db/%s # local-db-directory = ~ftp/db/%s # we will set up the lock-directory parameter, automatically # (lock-directory = temp-directory is default). # lock-directory = /tmp # regexp to GET from remote server. transfer-file-regexp += !/~$/ transfer-file-regexp += !/\/#/ transfer-file-regexp += !/\/\.#/ transfer-file-regexp += !/\/\.cache/ transfer-file-regexp += !/\/\.message/ transfer-file-regexp += !/\/\.mirror/ transfer-file-regexp += !/\/\.nfs/ transfer-file-regexp += !/\/\.notready/ transfer-file-regexp += !/\/\.in/ transfer-file-regexp += !/\/\.desc\.txt$/ transfer-file-regexp += !/\/core$/ transfer-file-regexp += !/\.core$/ # regexp to GET from remote server. transfer-directory-regexp += !/~\/$/ transfer-directory-regexp += !/\/lost\+found\/$/ # FreeBSD's remote and local directories are generic form. package = FreeBSD ftp-server = ftp.freebsd.org # GNU archives on RingServers also have generic directories. package = GNU ftp-server = ring.nacsis.ac.jp # mirror the Apache's tree from a RingServer. package = net/apache ftp-server = ring.asahi-net.or.jp # directories can be specified as follows: package = sendmail ftp-server = ftp.kyoto.wide.ad.jp remote-directory = /mail/sendmail local-directory = ~ftp/pub/mail/sendmail # mirror the whole tree from a RingServer. package = ring.aist.go.jp ftp-server = ring.aist.go.jp remote-directory = / local-directory = ~ftp override-directory-regexp += /^\.\/$/ override-directory-regexp += /^\.\/pub\// override-directory-regexp += /^\.\/ring\// override-directory-regexp += ! # copy web pages to a remote server (put mode). package = webcopy ftp-server = www.intec.co.jp ftp-user = www ftp-pass = nan-jara-hoi ftp-passive = yes put-mode = yes remote-directory = /usr/local/etc/httpd/htdocs local-directory = ~www/htdocs # if remote FTP server support index files, set db directories. package = utils ftp-server = ftp.intec.co.jp remote-db-directory = /db/%s local-db-directory = ~ftp/db/%s ftpmirror-1.96/install-sh100755 1751 1750 12721 6401320030 13741 0ustar ikuouser#! /bin/sh # # install - install a program, script, or datafile # This comes from X11R5 (mit/util/scripts/install.sh). # # Copyright 1991 by the Massachusetts Institute of Technology # # Permission to use, copy, modify, distribute, and sell this software and its # documentation for any purpose is hereby granted without fee, provided that # the above copyright notice appear in all copies and that both that # copyright notice and this permission notice appear in supporting # documentation, and that the name of M.I.T. not be used in advertising or # publicity pertaining to distribution of the software without specific, # written prior permission. M.I.T. makes no representations about the # suitability of this software for any purpose. It is provided "as is" # without express or implied warranty. # # Calling this script install-sh is preferred over install.sh, to prevent # `make' implicit rules from creating a file called install from it # when there is no Makefile. # # This script is compatible with the BSD install script, but was written # from scratch. It can only install one file at a time, a restriction # shared with many OS's install programs. # set DOITPROG to echo to test this script # Don't use :- since 4.3BSD and earlier shells don't like it. doit="${DOITPROG-}" # put in absolute paths if you don't have them in your path; or use env. vars. mvprog="${MVPROG-mv}" cpprog="${CPPROG-cp}" chmodprog="${CHMODPROG-chmod}" chownprog="${CHOWNPROG-chown}" chgrpprog="${CHGRPPROG-chgrp}" stripprog="${STRIPPROG-strip}" rmprog="${RMPROG-rm}" mkdirprog="${MKDIRPROG-mkdir}" transformbasename="" transform_arg="" instcmd="$mvprog" chmodcmd="$chmodprog 0755" chowncmd="" chgrpcmd="" stripcmd="" rmcmd="$rmprog -f" mvcmd="$mvprog" src="" dst="" dir_arg="" while [ x"$1" != x ]; do case $1 in -c) instcmd="$cpprog" shift continue;; -d) dir_arg=true shift continue;; -m) chmodcmd="$chmodprog $2" shift shift continue;; -o) chowncmd="$chownprog $2" shift shift continue;; -g) chgrpcmd="$chgrpprog $2" shift shift continue;; -s) stripcmd="$stripprog" shift continue;; -t=*) transformarg=`echo $1 | sed 's/-t=//'` shift continue;; -b=*) transformbasename=`echo $1 | sed 's/-b=//'` shift continue;; *) if [ x"$src" = x ] then src=$1 else # this colon is to work around a 386BSD /bin/sh bug : dst=$1 fi shift continue;; esac done if [ x"$src" = x ] then echo "install: no input file specified" exit 1 else true fi if [ x"$dir_arg" != x ]; then dst=$src src="" if [ -d $dst ]; then instcmd=: else instcmd=mkdir fi else # Waiting for this to be detected by the "$instcmd $src $dsttmp" command # might cause directories to be created, which would be especially bad # if $src (and thus $dsttmp) contains '*'. if [ -f $src -o -d $src ] then true else echo "install: $src does not exist" exit 1 fi if [ x"$dst" = x ] then echo "install: no destination specified" exit 1 else true fi # If destination is a directory, append the input filename; if your system # does not like double slashes in filenames, you may need to add some logic if [ -d $dst ] then dst="$dst"/`basename $src` else true fi fi ## this sed command emulates the dirname command dstdir=`echo $dst | sed -e 's,[^/]*$,,;s,/$,,;s,^$,.,'` # Make sure that the destination directory exists. # this part is taken from Noah Friedman's mkinstalldirs script # Skip lots of stat calls in the usual case. if [ ! -d "$dstdir" ]; then defaultIFS=' ' IFS="${IFS-${defaultIFS}}" oIFS="${IFS}" # Some sh's can't handle IFS=/ for some reason. IFS='%' set - `echo ${dstdir} | sed -e 's@/@%@g' -e 's@^%@/@'` IFS="${oIFS}" pathcomp='' while [ $# -ne 0 ] ; do pathcomp="${pathcomp}${1}" shift if [ ! -d "${pathcomp}" ] ; then $mkdirprog "${pathcomp}" else true fi pathcomp="${pathcomp}/" done fi if [ x"$dir_arg" != x ] then $doit $instcmd $dst && if [ x"$chowncmd" != x ]; then $doit $chowncmd $dst; else true ; fi && if [ x"$chgrpcmd" != x ]; then $doit $chgrpcmd $dst; else true ; fi && if [ x"$stripcmd" != x ]; then $doit $stripcmd $dst; else true ; fi && if [ x"$chmodcmd" != x ]; then $doit $chmodcmd $dst; else true ; fi else # If we're going to rename the final executable, determine the name now. if [ x"$transformarg" = x ] then dstfile=`basename $dst` else dstfile=`basename $dst $transformbasename | sed $transformarg`$transformbasename fi # don't allow the sed command to completely eliminate the filename if [ x"$dstfile" = x ] then dstfile=`basename $dst` else true fi # Make a temp file name in the proper directory. dsttmp=$dstdir/#inst.$$# # Move or copy the file name to the temp name $doit $instcmd $src $dsttmp && trap "rm -f ${dsttmp}" 0 && # and set any options; do chmod last to preserve setuid bits # If any of these fail, we abort the whole thing. If we want to # ignore errors from any of these, just make sure not to ignore # errors from the above "$doit $instcmd $src $dsttmp" command. if [ x"$chowncmd" != x ]; then $doit $chowncmd $dsttmp; else true;fi && if [ x"$chgrpcmd" != x ]; then $doit $chgrpcmd $dsttmp; else true;fi && if [ x"$stripcmd" != x ]; then $doit $stripcmd $dsttmp; else true;fi && if [ x"$chmodcmd" != x ]; then $doit $chmodcmd $dsttmp; else true;fi && # Now rename the file to the real destination. $doit $rmcmd -f $dstdir/$dstfile && $doit $mvcmd $dsttmp $dstdir/$dstfile fi && exit 0 ftpmirror-1.96/rotate100755 1751 1750 13624 7012375734 13210 0ustar ikuouser#!/usr/local/bin/perl ;# ;# Copyright (c) 1995-1999 ;# 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: rotate,v 1.6 1999/11/10 23:12:28 ikuo Exp $ ;# ;# How to use `rotate' program: ;# ;# To rotate "/var/log/xxx.log" to "/var/log/xxx.log.old", and ;# create a new file "/var/log/xxx.log": ;# rotate /var/log/xxx.log ;# ;# If you want to rotate files with suffixes, try additional ;# argument for `rotate' command. ;# rotate /var/log/xxx.log 2 1 0 ;# ;# You can specify the owner/group or file permission mode for ;# the new file (like `install' command): ;# rotate -o root -g wheel -m 644 /var/log/messages 2 1 0 ;# ;# You can also compress rotated file with `gzip': ;# rotate -z /var/log/access.log 2 1 0 ;# ;# or with `compress': ;# rotate -Z /var/log/access.log 2 1 0 ;# ;# This is because we supports perl version 4. require 'getopts.pl'; ;# Get program name ($program) = ($0 =~ m%([^/]+)$%); ;# For zero based index. $[ = 0; ;# Show debug log to STDOUT. sub debug { local($_); # used in grep. grep((print "$_\n"), @_) if $opt_v; } ;# Initialize options (for "perl -cw"). undef $opt_N; undef $opt_T; undef $opt_Z; undef $opt_g; undef $opt_m; undef $opt_n; undef $opt_o; undef $opt_t; undef $opt_v; undef $opt_z; ;# Parsing options unless (&Getopts("NTZg:m:no:tvz") && defined($target = shift)) { die <<"END"; Usage: $program [options] path [suffix suffix ...] Options: -v verbose mode. -n do not real work. only show processing. -N do not create a new file. -z compress with `gzip'. -Z compress with `compress'. -o specify owner. -g specify group. -m specify mode. -T use `YYYY-MM-DD' (given by current time) as the default suffix, instead of `old'. -t use `YYYY-MM-DD' (from last modified time of the target) as the default suffix, instead of `old'. END } ;# Test mode requires verbose option $opt_v++ if $opt_n; ;# If no suffix was given, we generate default one. unless (@ARGV) { if ($opt_T || $opt_t) { if ($opt_t && ! -e $target) { die("$target must exist if -t flag is specified.\n"); } $t = $opt_t ? (stat($target))[9] : time; @t = reverse((localtime($t))[0..5]); $t[0] += 1900; $t[1]++; @ARGV = (sprintf("%04d-%02d-%02d", @t)); } else { @ARGV = ('old'); } } ;# Rotate the target file. &safe_rotate($target, @ARGV); ;# Touch the new one. &safe_create($target) unless $opt_N; ;# Normal termination. exit; ;# Touch a file. Create a new one if it does not exist. sub touch { local($a) = @_; local(*FILE); $a ne '' && open(FILE, '>>'.$a) && close(FILE) && -e $a; } ;# sub safe_unlink { local($a) = @_; if (-e $a) { &debug("unlink \"$a\""); $opt_n || unlink($a) || die("unlink($a): $!"); } } ;# sub safe_rename { local($a, $b) = @_; # from, to if (-e $a) { &debug("rename \"$a\" to \"$b\""); $opt_n || rename($a, $b) || die("rename($a, $b): $!"); } } ;# sub safe_compress { local($a) = @_; if (-z $a) { # compress will fail in this case &debug("we won't compress zero-sized file: \"$a\""); } else { &debug("compress \"$a\""); $opt_n || system('compress', $a) == 0 || die("system(compress, $a): failure.\n"); } } ;# sub safe_gzip { local($a) = @_; &debug("gzip \"$a\""); $opt_n || system('gzip', $a) == 0 || die("system(gzip, $a): failure.\n"); } ;# Create a new one sub safe_create { local($a) = shift; &debug("touch \"$a\""); $opt_n || &touch($a) || die("touch($a): $!"); # set owner and group if (defined($opt_o) || defined($opt_g)) { local($uid, $gid) = (stat($a))[4, 5]; !defined($opt_o) || (($uid = $opt_o) =~ /^\d+$/) || defined($uid = getpwnam($opt_o)) || die("getpwnam($opt_o): $!"); !defined($opt_g) || (($gid = $opt_g) =~ /^\d+$/) || defined($gid = getgrnam($opt_g)) || die("getgrnam($opt_g): $!"); &debug("chown($uid, $gid, \"$a\")"); $opt_n || chown($uid, $gid, $a) || die("chown($a): $!"); } # set file mode if (defined($opt_m)) { $opt_m =~ /^\d+$/ || die "illegal mode: $opt_m\n"; $opt_m = oct($opt_m); &debug("chmod ".sprintf("%04o", $opt_m).", \"$a\""); $opt_n || chmod($opt_m, $a) || die("chmod($a): $!"); } # success. 1; } ;# Rotate - do real work. sub safe_rotate { local($a) = shift; # check existence, and suffixes return 0 unless $a ne '' && -e $a && @_; # log message &debug("rotating \"$a\""); # remove oldest one local($b) = $a.'.'.shift; &safe_unlink($b); &safe_unlink($b.'.Z'); &safe_unlink($b.'.gz'); # loop to rotate files while (@_) { local($x) = $a.'.'.shift; &safe_rename($x, $b); &safe_rename($x.'.Z', $b.'.Z'); &safe_rename($x.'.gz', $b.'.gz'); $b = $x; } # rotate last one &safe_rename($a, $b); # shall we compress rotated one? $opt_z ? &safe_gzip($b) : $opt_Z ? &safe_compress($b) : 1; } ftpmirror-1.96/tools/ 40755 1751 1750 0 7031563577 13006 5ustar ikuouserftpmirror-1.96/tools/generator100644 1751 1750 20740 6401320027 15014 0ustar ikuouser;# ;# ftpmirror.PL ;# This script generates ftpmirror. ;# use Config; use strict; use vars qw($this); ;# ($this) = $0 =~ /([^\/]+)$/; $this =~ s/\.PL$// || die("$0: no PL extension.\n"); ;# $this eq 'ftpmirror' or die("$0: only ftpmirror can be generated.\n"); ;# if (-f $this) { my $old = $this.'.old'; if (-f $old) { print("unlink($old)...\n"); unlink($old); } print("rename($this, $old)...\n"); rename($this, $old); } print("writing $this...\n"); open(OUT, ">$this") || die("open($this): $!"); print OUT $Config{startperl}."\n"; print OUT while ; close(OUT); ;# print("chmod(0555, $this)...\n"); chmod(0555, $this); ;# # $startperl = $Config{startperl}; # $sitearch = $Config{sitearch}; # $sitelib = $Config{sitelib}; ;# End of script. ;# __END__ ;# ;# Copyright (c) 1995-1997 ;# 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: generator,v 1.1 1997/08/28 15:58:15 ikuo Exp $ ;# ;# use strict; use vars qw($VERSION $LOG $todo $sysconfdir $loader %initval); ;# modules use Ring::Cool; use Ring::Loader; use Ring::Archive; ;# $VERSION = '0.12'; ($todo) = $0 =~ m|([^/]+)$|; ;# BEGIN { ;# For non-blocking stdout. $| = 1; $LOG = 5; # Data and time string. my $t = time; my $s = str4date($t).' '.str4time($t); # Show start up message. warn("$s FTPMIRROR starting...\n") if $LOG > 5; } ;# END { # Data and time string. my $t = time; my $s = str4date($t).' '.str4time($t); ;# Show terminate message. warn("$s FTPMIRROR terminated\n") if $LOG > 5; } ;# initialization... { use Config; # system configuration files $sysconfdir = $Config{prefix}.'/etc'; } ;# %initval = ( 'sysconfdir' => $sysconfdir, 'load-config' => "ftpmirror.cf", 'create-directories' => 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' => '~', ); ;# $loader = Ring::Loader->new(\%Ring::Archive::pkeys); ref($loader) && $loader->isa('Ring::Loader') or die("Can't create loader"); ;# Initial default parameters. $loader->merge_hash(\%initval, 'INIT') or die("Loader: Can't initialize values"); ;# Parsing options. while (@ARGV && $ARGV[$[] =~ s/^--//) { local $_ = shift; $loader->parse_line($_, 'OPTION') == 1 or die("Loader: Can't parse option: $_\n"); } ;# Set logging level first. if (defined($_ = $loader->get_value('log-mask', 'INIT', 'OPTION'))) { plog_mask($_); } ;# Get 'load-config' parameter if (defined($_ = $loader->get_value('load-config', 'INIT', 'OPTION'))) { # get 'load-config' parameter my $dir = $loader->get_value('sysconfdir', 'INIT', 'OPTION'); # debug... warn("load files = $_\n") if $LOG > 6; # load configuration files for my $file (split(/\s+/)) { next if $file eq ''; $file = "$dir/$file" if ! -f $file && $dir ne ''; warn("loading $file...\n") if $LOG > 5; $loader->parse_file($file, 'DEFAULT') or die ("Loader Can't parse $file.\n"); } } ;# if ($LOG > 5) { print("starting resource usage:\n"); &show_usage(); } ;# while (@ARGV) { my $name = shift; my $pack = 'PACKAGE::'.$name; # Search this package... unless ($loader->search($pack)) { warn("Loader: package $pack not defined, skip...\n"); next; } # Try to generate Archive object. my $srv = $loader->get_value('ftp-server', 'INIT', 'DEFAULT', $pack, 'OPTION'); if ($srv eq '') { warn("Loader: package $pack has no FTP server, skip...\n"); next; } # Get servers parameter object. my @list; if ($loader->search("SERVER::$srv")) { @list = ('INIT', 'DEFAULT', "SERVER::$srv", $pack, 'OPTION'); } else { @list = ('INIT', 'DEFAULT', $pack, 'OPTION'); } # Generate a new Archive object. my $p = Ring::Archive->new(param_name => 'RUN::'.$name); ref($p) && $p->isa('Ring::Param') or die("Can't create Param object.\n"); # Merge parameters. for my $n (@list) { $p->merge($loader->search($n)); } $p->check or warn("check error.\n"), next; if ($todo eq 'ftpmirror') { $p->mirror; # start... } elsif ($todo eq 'dirscan') { &dirscan($p); } elsif ($todo eq 'mkdirinfo') { use Ring::DIR; my $dir = $p->local_directory; my $info = Ring::DIR->new(dir_path => $dir); ref($info) or warn("DIR($dir) not initialized.\n"), next; if ($info->update) { # this is a recursive call. warn("$dir: modified.\n") if $LOG > 5; } else { warn("$dir: not modified.\n") if $LOG > 5; } } elsif ($todo eq 'indexutil') { use Ring::Pias; my $dir = $p->index_directory; if ($dir eq '') { warn("index directory not found for $todo\n"); next; } if (! -d $dir) { warn("$dir: directory not found for $todo\n"); next; } my $pias = Ring::Pias->new($dir); unless (ref($pias)) { warn("$dir: Can't initialize Pias.\n"); next; } unless ($pias->update) { warn("$dir: Can't update index directory.\n"); next; } warn("updating $dir... good\n") if $LOG > 5; } else { die("$todo: What shall i do?\n"); } ;# if ($LOG > 5) { print("resource usage after $name done:\n"); &show_usage(); } } ;# before termination, we'd like to see reports. { $Ring::FTP::LOG = 6; $Ring::TCP::LOG = 6; $Ring::Attrib::LOG = 6; } ;# exit; ;# sub pias_run { my $p = shift; # Ring::Archive object. my $pias = $p->ref_pias; my $cmd = shift; unless (ref($pias) && $pias->isa('Ring::Pias')) { return undef; } if ($cmd eq 'STEP') { my $scan = Ring::Scan->new( scan_type => 'LOCAL', scan_dir => $p->local_directory ); $pias->d_start || die("d_start failed"); my $x; while (defined($x = $scan->get)) { $pias->d_check($x) || die("d_check failed"); } # $pias->d_end; } elsif ($cmd eq 'UPDATE') { $pias->update || die("update failed"); } elsif ($cmd eq 'CLEANUP') { $pias->cleanup || die("cleanup failed"); } elsif ($cmd eq 'NORMALIZE') { $pias->normalize || die("normalize failed"); } else { $pias->force($p->local_directory, 1) or die("force failed"); } } ;# sub dirscan { my $p = shift; local $SIG{'USR1'} = \&show_usage; use Ring::Scan; my $scan; if ($p->scan_remote) { use Ring::FTP; my $ftp = Ring::FTP->new( ftp_server => $p->ftp_server, ftp_gateway => $p->ftp_gateway, ftp_user => $p->ftp_user, ftp_pass => $p->ftp_pass ); ref($ftp) && $ftp->isa('Ring::FTP') or die("Can't create FTP object"); $ftp->login or die("Can't login to server"); $ftp->chdir($p->remote_directory) or die("ftp->chdir failed"); $scan = Ring::Scan->new( scan_type => 'FTP', scan_ftp => $ftp, scan_dir => $p->remote_directory ); ref($scan) or die("Can't create Scan object"); } else { $scan = Ring::Scan->new( scan_type => 'LOCAL', scan_dir => $p->local_directory ); ref($scan) or die("Can't create Scan object"); } my $x; while (defined($x = $scan->get)) { my $t = $x->type; print $x->path."\n" if $t ne 'U' && $t ne '.'; } 1; } ;# sub show_usage { use Ring::Usage; if (@_) { my $sig = shift; warn("* signal $sig detected.\n"); } my $u = getrusage; $u->dump; undef $u; 1; } =head1 NAME ftpmirror - Mirror directory hiearachy via FTP. =head1 SYNOPSIS C =head1 DESCRIPTION Ftpmirror mirrors directory hiearachy via FTP. =head1 AUTHER Ikuo Nakagawa, Aug, 1997 =item =cut ftpmirror-1.96/tools/pack.pl100755 1751 1750 7113 6402775641 14361 0ustar ikuouser#!/usr/local/bin/perl ;# ;# Copyright (c) 1996, 1997 ;# 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$ ;# use strict; use vars qw($package $version $dir $opt_v $opt_d $tar_flags $gzip_flags @file); ;# we use getopts. use Getopt::Std; ;# get our name ($program) = $0 =~ m|([^/]+)$|; ;# show message and die. sub usage { die("Usage: $program [-v] package [version]\n"); } ;# parse options. getopts("vd") && (@ARGV == 1 || @ARGV == 2) or &usage; $package = shift; $version = @ARGV ? shift : undef; ;# debug log if ($opt_d) { print STDERR "* package=$package"; print STDERR ", version=$version" if $version ne ''; print STDERR "\n"; } ;# If $version is given, try to use it, ;# otherwise try to find newest version of the package. if ($version ne '') { $dir = "$package-$version"; if (! -d $dir) { print STDERR "$package-$version: directory not found\n" if $opt_v; &usage; } } else { my $e; $dir = ''; local *DIR; opendir(DIR, ".") || die("opendir(.): $!\n"); while (defined($e = readdir(DIR))) { next if $e eq '.' || $e eq '..'; if ($e eq $package || $e =~ /^$package(-|\.)/) { $dir = $e if -d $e && $dir lt $e; } } close(DIR); if ($dir eq '') { print STDERR "$package: no directory found\n" if $opt_v; &usage; } } ;# print STDERR "* directory=$dir\n" if $opt_d; ;# do real work if (-f "$dir.tar") { print STDERR "* unlink $dir.tar\n" if $opt_d; unlink("$dir.tar"); } if (-f "$dir.tar.gz") { print STDERR "* unlink $dir.tar.gz\n" if $opt_d; unlink("$dir.tar.gz"); } ;# if ($opt_d) { print STDERR "* archiving $dir...\n"; $tar_flags = 'cvf'; } else { $tar_flags = 'cf'; } ;# Search files open(PIPE, "find '$dir' -type f -print|") || die("open(find): $!"); while () { chomp; next if /CVS/; next if /\/\.depend$/; print STDERR "* add $_\n" if $opt_d; push(@file, $_); } close(PIPE); die("find: $!") if $?; ;# check existence of target files @file || die("no file found in $dir\n"); ;# sorting @file = sort(@file); ;# Now, try to invoke tar. system("tar", $tar_flags, "$dir.tar", @file); die("system: $!") if $?; ;# verbose message if ($opt_d) { print STDERR "* compressing $dir.tar...\n"; $gzip_flags = '-9fnv'; } else { $gzip_flags = '-9fn'; } ;# Now, try to invoke gzip. system "gzip", $gzip_flags, "$dir.tar"; die("system: $!") if $?; ;# print STDERR "$dir ... ok\n" if $opt_v; ftpmirror-1.96/tools/pm_utils.pl100755 1751 1750 5622 6600626052 15271 0ustar ikuouser#!/usr/local/bin/perl ;# use strict; use vars qw($opt_l $opt_v %save); use Getopt::Std; ;# BEGIN { %save = (); } ;# END { my $file; my $save; while (($file, $save) = each %save) { if (rename($save, $file)) { warn("restore $save -> $file: o.k.\n") if $opt_v; } else { warn("rename($save, $file): $!\n"); } } } ;# prototypes sub pm_find ($;$); sub pm_copy ($$); sub pm_comp ($$); sub pm_conv ($;$); ;# parse options getopts("lv") || die("Usage: $0 [-l] [-v] [file...]\n"); ;# default files. @ARGV = &pm_find('.', $opt_l) unless @ARGV; ;# do real work. for my $i (@ARGV) { my $save = $i.'.save'; unlink($save) if -e $save; $save{$i} = $save; rename($i, $save) or die("rename($i, $save): $!\n"); warn("save $i -> $save: o.k.\n") if $opt_v; &pm_copy($save, $i) or die("pm_copy($save, $i): $!\n"); warn("copy $save -> $i: o.k.\n") if $opt_v; &pm_conv($i, 0) or die("pm_conv($i, 0): failed\n"); warn("convert $i: o.k.\n") if $opt_v; } ;# try check... for my $i (@ARGV) { system '/usr/local/bin/perl', '-cw', $i; } # success return. exit; ;# sub pm_find ($;$) { my $dir = shift; my $norecurse = shift; my @array = (); local *DIR; opendir(DIR, $dir) or die("find: opendir($dir): $!\n"); for my $e (sort readdir(DIR)) { next if $e eq '.' || $e eq '..'; my $p = "$dir/$e"; next if $norecurse && -d $p; next if $e eq 'blib' && -d $p; push(@array, $p), next if -f $p && $p =~ /\.pm$/; push(@array, &pm_find($p)), next if -d $p; } closedir(DIR); @array; } ;# sub pm_copy ($$) { my $from = shift; my $to = shift; -f $from or die("pm_copy: $from is not a plan file.\n"); local *FROM; open(FROM, $from) or die("copy: open($from): $!\n"); local *TO; open(TO, '>'.$to) or die("copy: open(>$to): $!\n"); local $_; print TO while ; close(TO); close(FROM); # success 1; } ;# sub pm_comp ($$) { my $old = shift; my $new = shift; local *OLD; open(OLD, $old) or die("comp: open($old): $!\n"); local *NEW; open(NEW, $new) or die("comp: open($new): $!\n"); my $a = undef; my $b = undef; while (defined($a = ) && defined($b = )) { my $comp = $a cmp $b; return $comp if $comp; } close(OLD); close(NEW); defined($a) ? 1 : defined($b) ? -1 : 0; } ;# sub pm_conv ($;$) { my $file = shift; my $split = @_ ? shift : 0; my $delim = $split ? '/;# A special marker for AutoSplit/' : '$'; local *PIPE; my $pid = open(PIPE, "|-"); defined($pid) or die("pm_conv: can't fork: $!\n"); if ($pid == 0) { # in kid's process... open(STDOUT, ">/dev/null"); open(STDERR, ">/dev/null"); exec 'ed', '-', '-s', $file; die("pm_conv: exec(ed): $!\n"); } # or in parent's process print PIPE "g/^__END__\$/d\n"; print PIPE "g/^1;\$/d\n"; print PIPE "$delim\n"; print PIPE "a\n"; print PIPE "1;\n"; print PIPE "__END__\n"; print PIPE ".\n"; print PIPE "w\n"; print PIPE "q\n"; close(PIPE); # check result of editor. die("conv: ed returns $?") if $?; # success 1; } ftpmirror-1.96/tools/pmirror100755 1751 1750 7025 6412745132 14516 0ustar ikuouser#!/usr/local/bin/perl ;# ;# Copyright (c) 1995-1997 ;# 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: pmirror,v 1.1 1997/09/26 14:44:42 ikuo Exp $ ;# use strict; use vars qw($opt_C $opt_d $opt_f $opt_l $opt_p $opt_v); use Getopt::Std; getopts("C:df:l:p:v") or die("Usage: $0 [-C dir] [-v] [-p #] [archive...]\n"); ;# Change working directory if -C option was specified. if ($opt_C ne '' && -d $opt_C) { chdir($opt_C) or die("chdir($opt_C): $!\n"); } ;# Redirect log messages if -l option was given. if ($opt_l ne '') { open(STDERR, '>>'.$opt_l) or die("open($opt_l): $!\n"); open(STDOUT, '>&STDERR') or die("open(STDOUT): $!\n"); } ;# No parallel session allowed in debug mode. if ($opt_d || $opt_p < 1) { $opt_p = 1; } ;# Reading archive names from a file. if ($opt_f) { local *FILE; -f $opt_f or die("$opt_f: file not found\n"); open(FILE, $opt_f) or die("open($opt_f): $!\n"); while () { s/^\s+//; s/\s+$//; next if /^$/ || /^#/; push(@ARGV, $_); } close(FILE); } ;# Check target archives. @ARGV or die("nothing to do, terminated.\n"); ;# Do real work in `loop'. &loop(@ARGV); ;# And success return. exit; ;# Do real work. sub loop { my %kids = (); my $n = 0; while (@_ || %kids) { while (@_ && $n < $opt_p) { my $x = shift; my $p = &run($x); warn("target \"$x\" [$p] started.\n"); $kids{$p} = $x; $n++; } if ((my $kids = join(',', values %kids)) ne '') { warn("running: $kids\n"); } if ((my $p = wait) >= 0) { warn("kid[$p] returns $?\n"); if (exists($kids{$p})) { warn("target \"$kids{$p}\" [$p] done.\n"); delete($kids{$p}); $n--; } } } 1; } ;# Run mirror process in child. sub run { my $pac = shift; my $log = "log/$pac.log"; if (!defined(my $pid = fork)) { die("fork: $!\n"); } elsif ($pid) { return $pid; # in parent... } # in KID's process if (!$opt_d) { if (-e $log) { system 'rotate', $log, '3', '2', '1', '0'; $? == 0 or die("rotate($log): returns $?\n"); } open(STDERR, '>'.$log) or die("open($log): $!\n"); open(STDOUT, '>&STDERR') or die("open(STDOUT): $!\n"); } # Run mirror procces. exec '/usr/bin/time', '-l', 'ftpmirror', '--ftp-list-method=LIST', '--load-config+=run.cf', '--verbose', '--ftp-stats', $pac or die("exec: $!\n"); # NOT REACHED } ftpmirror-1.96/tools/run.pl100755 1751 1750 6337 6407523527 14255 0ustar ikuouser#!/usr/local/bin/perl ;# ;# Copyright (c) 1995-1997 ;# 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: run.pl,v 1.2 1997/09/16 15:35:51 ikuo Exp $ ;# use strict; use vars qw($opt_d $opt_f $opt_l $opt_p $opt_v $todo $dir); use Getopt::Std; $dir = '/u/ftpadmin/run'; chdir($dir) or die("chdir: $!\n"); $todo = 'full-mirror'; getopts("df:l:p:v") or die("Usage: $0 [-v] [-p #] [archive...]\n"); if ($opt_l) { open(STDERR, '>>'.$opt_l) or die("open($opt_l): $!\n"); open(STDOUT, '>&STDERR') or die("open(STDOUT): $!\n"); } $opt_p = 1 if $opt_d || $opt_p < 1; if ($opt_f) { local *FILE; -f $opt_f or die("$opt_f: file not found\n"); open(FILE, $opt_f) or die("open($opt_f): $!\n"); while () { s/^\s+//; s/\s+$//; next if /^$/ || /^#/; push(@ARGV, $_); } close(FILE); } if (@ARGV == 0) { warn("nothing to do, terminate\n"); } else { &loop(@ARGV); } exit; sub loop { my %kids = (); my $n = 0; while (@_ || %kids) { while (@_ && $n < $opt_p) { my $x = shift; my $p = &run($x); warn("target \"$x\" [$p] started.\n"); $kids{$p} = $x; $n++; } if ((my $kids = join(',', values %kids)) ne '') { warn("running: $kids\n"); } if ((my $p = wait) >= 0) { warn("kid[$p] returns $?\n"); if (exists($kids{$p})) { warn("target \"$kids{$p}\" [$p] done.\n"); delete($kids{$p}); $n--; } } } 1; } sub run { my $pac = shift; my $log = "log/$pac.log"; if (!defined(my $pid = fork)) { die("fork: $!\n"); } elsif ($pid) { return $pid; # in parent... } if (!$opt_d && -e $log) { system 'rotate', $log, '3', '2', '1', '0'; $? == 0 or warn("rotate($log): returns $?\n"), next; open(STDERR, '>'.$log) or warn("open($log): $!\n"), next; open(STDOUT, '>&STDERR') or warn("can't redirect stdout: $!\n"), next; } exec '/usr/bin/time', '-l', 'ftpmirror', '--todo='.$todo, '--ftp-list-method=LIST', '--load-config+=run.cf', '--log-mask=Fan=6,Fan::Farm=6', '--ftp-stats', $pac or die("exec: $!\n"); }