File Coverage

blib/lib/App/Upfiles.pm
Criterion Covered Total %
statement 40 491 8.1
branch 0 220 0.0
condition 0 93 0.0
subroutine 14 43 32.5
pod 2 25 8.0
total 56 872 6.4


line stmt bran cond sub pod time code
1             # Copyright 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2017 Kevin Ryde
2              
3             # This file is part of Upfiles.
4             #
5             # Upfiles is free software; you can redistribute it and/or modify it under
6             # the terms of the GNU General Public License as published by the Free
7             # Software Foundation; either version 3, or (at your option) any later
8             # version.
9             #
10             # Upfiles is distributed in the hope that it will be useful, but WITHOUT
11             # ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
12             # FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for
13             # more details.
14             #
15             # You should have received a copy of the GNU General Public License along
16             # with Upfiles. If not, see .
17              
18              
19             # Net::FTP
20             # RFC 959 - ftp
21             # RFC 1123 - program ftp minimum requirements
22             # RFC 1579 - PASV
23             # RFC 2228 - PROT
24             # RFC 3659 - Extensions to FTP (MDTM fetch, REST, MLST)
25             # RFC 4217 - SSL
26             # http://cr.yp.to/ftp.html DJB's notes
27             # https://tools.ietf.org/id/draft-somers-ftp-mfxx-04.txt MFMT etc
28             #
29             # proftpd
30             # /usr/share/doc/proftpd-doc/modules/mod_site.html
31              
32              
33             package App::Upfiles;
34 1     1   385 use 5.010;
  1         8  
35 1     1   4 use strict;
  1         1  
  1         15  
36 1     1   4 use warnings;
  1         2  
  1         17  
37 1     1   4 use Carp;
  1         6  
  1         52  
38 1     1   5 use File::Spec;
  1         1  
  1         18  
39 1     1   3 use File::Spec::Unix;
  1         2  
  1         26  
40 1     1   227 use File::stat 1.02; # for -d operator overload
  1         6217  
  1         5  
41 1     1   52 use List::Util 'max';
  1         1  
  1         73  
42 1     1   305 use POSIX ();
  1         5098  
  1         26  
43 1     1   305 use Locale::TextDomain ('App-Upfiles');
  1         12213  
  1         4  
44 1     1   5644 use Regexp::Common 'no_defaults','Emacs';
  1         1871  
  1         3  
45              
46 1     1   1353 use FindBin;
  1         725  
  1         68  
47             my $progname = $FindBin::Script;
48              
49             our $VERSION = 12;
50              
51             # uncomment this to run the ### lines
52             # use Smart::Comments;
53              
54              
55             use constant { DATABASE_FILENAME => '.upfiles.sqdb',
56             DATABASE_SCHEMA_VERSION => 1,
57              
58             CONFIG_FILENAME => '.upfiles.conf',
59              
60             # emacs backups, autosaves, lockfiles
61 1         6 EXCLUDE_BASENAME_REGEXPS_DEFAULT => [ $RE{Emacs}{skipfile} ],
62              
63             EXCLUDE_REGEXPS_DEFAULT => [],
64 1     1   6 };
  1         1  
65              
66             #------------------------------------------------------------------------------
67             sub new {
68 3     3 1 2851 my $class = shift;
69 3         23 return bless { total_size_kbytes => 0,
70             total_count => 0,
71             change_count => 0,
72             change_size => 0,
73             verbose => 1,
74              
75             exclude_regexps_default
76             => $class->EXCLUDE_REGEXPS_DEFAULT,
77              
78             exclude_basename_regexps_default
79             => $class->EXCLUDE_BASENAME_REGEXPS_DEFAULT,
80              
81             @_ }, $class;
82             }
83              
84              
85             #------------------------------------------------------------------------------
86             sub command_line {
87 0     0 1   my ($self) = @_;
88              
89 0           my $action = '';
90             my $set_action = sub {
91 0     0     my ($new_action) = @_;
92 0 0         if ($action) {
93 0           croak __x('Cannot have both action {action1} and {action2}',
94             action1 => "--$action",
95             action2 => "--$new_action");
96             }
97 0           $action = "$new_action"; # stringize against callback object :-(
98 0           };
99              
100 0           require Getopt::Long;
101 0           Getopt::Long::Configure ('no_ignore_case',
102             'bundling');
103 0 0         if (! Getopt::Long::GetOptions ('help|?' => $set_action,
104             'verbose:+' => \$self->{'verbose'},
105             'V+' => \$self->{'verbose'},
106             'version' => $set_action,
107             'n|dry-run' => \$self->{'dry_run'},
108             'recheck' => \$self->{'recheck'},
109             'catchup' => \$self->{'catchup'},
110             )) {
111 0           return 1;
112             }
113              
114 0 0         if ($self->{'verbose'} >= 2) {
115 0           print "Verbosity level $self->{'verbose'}\n";
116             }
117 0   0       $action = 'action_' . ($action || 'upfiles');
118 0           return $self->$action;
119             }
120              
121             sub action_version {
122 0     0 0   my ($self) = @_;
123 0           print __x("upfiles version {version}\n",
124             version => $self->VERSION);
125 0 0         if ($self->{'verbose'} >= 2) {
126 0           require DBI;
127 0           require DBD::SQLite;
128 0           print __x(" Perl version {version}\n", version => $]);
129 0           print __x(" DBI version {version}\n", version => $DBI::VERSION);
130 0           print __x(" DBD::SQLite version {version}\n", version => $DBD::SQLite::VERSION);
131             }
132 0           return 0;
133             }
134              
135             sub action_help {
136 0     0 0   my ($self) = @_;
137 0           print __x("Usage: $progname [--options]\n");
138 0           print __x(" --help print this message\n");
139 0           print __x(" --version print version number (and module versions if --verbose=2)\n");
140 0           print __x(" -n, --dry-run don't do anything, just print what would be done\n");
141 0           print __x(" --verbose, --verbose=N
142             print diagnostic info, with --verbose=2 print even more info\n");
143 0           return 0;
144             }
145              
146             sub action_upfiles {
147 0     0 0   my ($self, @files) = @_;
148             ### action_upfiles() ...
149             ### @ARGV
150              
151 0 0         if (@ARGV) {
152             # files given on command line
153 0           @files = @ARGV;
154 0           @files = map {File::Spec->rel2abs($_)} @files;
  0            
155             ### @files
156 0           @files = map {$_, parent_directories($_)} @files;
  0            
157             ### @files
158 0           my %hash;
159 0           @hash{@files} = (); # hash slice
160             ### %hash
161 0           local $self->{'action_files_hash'} = \%hash;
162 0           $self->do_config_file;
163              
164             } else {
165             # all files
166 0           $self->do_config_file;
167              
168 0 0         if (! $self->{'recheck'}) {
169             print __x("changed {change_count} files {change_size_kbytes}k, total {total_count} files {total_size_kbytes}k (in 1024 byte blocks)\n",
170             change_count => $self->{'change_count'},
171             change_size_kbytes => _bytes_to_kbytes($self->{'change_size'}),
172             total_count => $self->{'total_count'},
173 0           total_size_kbytes => $self->{'total_size_kbytes'});
174             }
175             }
176 0           return 0;
177             }
178             sub _bytes_to_kbytes {
179 0     0     my ($bytes) = @_;
180 0           return POSIX::ceil($bytes/1024);
181             }
182              
183             # return a list of the directory and all parent directories of $filename
184             sub parent_directories {
185 0     0 0   my ($filename) = @_;
186 0           my @ret;
187 0           for (;;) {
188 0           my $parent = File::Spec->rel2abs(File::Basename::dirname($filename));
189 0 0         last if $parent eq $filename;
190 0           push @ret, $parent;
191 0           $filename = $parent;
192             }
193 0           return @ret;
194             }
195              
196             #------------------------------------------------------------------------------
197             sub do_config_file {
198 0     0 0   my ($self) = @_;
199 0           my $config_filename = $self->config_filename;
200 0 0         if ($self->{'verbose'} >= 2) {
201 0           print __x("config: {filename}\n",
202             filename => $config_filename);
203             }
204 0 0         if ($self->{'dry_run'}) {
205 0 0         if ($self->{'verbose'}) { print __x("dry run\n"); }
  0            
206             }
207 0           require App::Upfiles::Conf;
208 0           local $App::Upfiles::Conf::upf = $self;
209              
210 0 0         if (! defined (do { package App::Upfiles::Conf;
211 0           do $config_filename;
212             })) {
213 0 0         if (! -e $config_filename) {
214 0           croak __x("No config file {filename}",
215             filename => $config_filename);
216             } else {
217 0           croak $@;
218             }
219             }
220             }
221             sub config_filename {
222 0     0 0   my ($self) = @_;
223 0   0       return $self->{'config_filename'} // do {
224 0           require File::HomeDir;
225 0   0       my $homedir = File::HomeDir->my_home
226             // croak __('No home directory for config file (File::HomeDir)');
227 0           return File::Spec->catfile ($homedir, $self->CONFIG_FILENAME);
228             };
229             }
230              
231             #------------------------------------------------------------------------------
232              
233             my %protocol_to_class = (ftp => 'App::Upfiles::FTPlazy',
234             ftps => 'App::Upfiles::FTPlazy',
235             sftp => 'App::Upfiles::SFTPlazy',
236             );
237             sub ftp {
238 0     0 0   my ($self) = @_;
239 0           my $protocol = $self->{'protocol'};
240 0           my $options = $self->{'options'};
241              
242             # Here $key becomes ftp, ftp.TLS, ftps or sftp and a corresponding type of
243             # lazy connection is cached. The two ftp or ftp.TLS could be merged by
244             # setting the TLS option dynamically, but expect normally to be using just
245             # one or the other.
246 0           my $key = $protocol;
247 0 0 0       if ($protocol eq 'ftp' && $options->{'use_TLS'}) {
248 0           $key .= '.TLS';
249             }
250             return ($self->{'ftp'}->{$key}
251 0   0       //= do {
252             my $class = $protocol_to_class{$protocol}
253             or croak __x('Unrecognised protocol to remote: {protocol}',
254 0 0         protocol => $self->{'protocol'});
255 0           require Module::Load;
256 0           Module::Load::load($class);
257             $class->new (verbose => $self->{'verbose'},
258             copy_time => $options->{'copy_utime'}?1:0, # for SFTP
259             ($protocol eq 'ftps'
260             ? (use_SSL => 1)
261 0 0         : (use_TLS => $options->{'use_TLS'})),
    0          
262             )
263             });
264             }
265              
266             sub ftp_connect {
267 0     0 0   my ($self) = @_;
268 0           my $ftp = $self->ftp;
269             $ftp->ensure_all
270             or croak __x("{protocol} error on {hostname}: {ftperr}",
271 0 0         protocol => $self->{'protocol'},
272             hostname => $ftp->host,
273             ftperr => scalar($ftp->message));
274             }
275              
276              
277             # return ($mtime, $size) of last send of $filename to url $remote
278             sub db_get_mtime {
279 0     0 0   my ($self, $dbh, $remote, $filename) = @_;
280 0           my $sth = $dbh->prepare_cached
281             ('SELECT mtime,size FROM sent WHERE remote=? AND filename=?');
282 0           my $aref = $dbh->selectall_arrayref($sth, undef, $remote, $filename);
283 0   0       $aref = $aref->[0] || return; # if no rows
284 0           my ($mtime, $size) = @$aref;
285 0           $mtime = timestamp_to_timet($mtime);
286 0           return ($mtime, $size);
287             }
288              
289             sub db_set_mtime {
290 0     0 0   my ($self, $dbh, $remote, $filename, $mtime, $size) = @_;
291 0 0         if ($self->{'verbose'} >= 2) {
292 0           print " database write $filename time=$mtime,size=$size\n";
293             }
294 0           $mtime = timet_to_timestamp($mtime);
295 0           my $sth = $dbh->prepare_cached
296             ('INSERT OR REPLACE INTO sent (remote,filename,mtime,size)
297             VALUES (?,?,?,?)');
298 0           $sth->execute ($remote, $filename, $mtime, $size);
299             }
300              
301             sub db_delete_mtime {
302 0     0 0   my ($self, $dbh, $remote, $filename) = @_;
303 0 0         if ($self->{'verbose'} >= 2) {
304 0           print " database delete $filename\n";
305             }
306 0           my $sth = $dbh->prepare_cached
307             ('DELETE FROM sent WHERE remote=? AND filename=?');
308 0           $sth->execute ($remote, $filename);
309             }
310              
311             sub db_remote_filenames {
312 0     0 0   my ($dbh, $remote) = @_;
313 0           my $sth = $dbh->prepare_cached
314             ('SELECT filename FROM sent WHERE remote=?');
315 0           return @{$dbh->selectcol_arrayref($sth, undef, $remote)};
  0            
316             }
317              
318             # return a DBD::SQLite handle for database $db_filename
319             sub dbh {
320 0     0 0   my ($self, $db_filename) = @_;
321              
322 0 0         if ($self->{'verbose'} >= 2) {
323 0           print "database open $db_filename\n";
324             }
325              
326 0           require DBD::SQLite;
327 0           my $dbh = DBI->connect ("dbi:SQLite:dbname=$db_filename",
328             '', '', {RaiseError=>1});
329 0           $dbh->func(90_000, 'busy_timeout'); # 90 seconds
330              
331             {
332 0           my ($dbversion) = do {
  0            
333 0           local $dbh->{RaiseError} = undef;
334 0           local $dbh->{PrintError} = undef;
335 0           $dbh->selectrow_array
336             ("SELECT value FROM extra WHERE key='database-schema-version'")
337             };
338 0   0       $dbversion ||= 0;
339 0 0         if ($dbversion < $self->DATABASE_SCHEMA_VERSION) {
340 0           $self->_upgrade_database ($dbh, $dbversion, $db_filename);
341             }
342             }
343 0           return $dbh;
344             }
345              
346             sub _upgrade_database {
347 0     0     my ($self, $dbh, $dbversion, $db_filename) = @_;
348              
349 0 0         if ($dbversion <= 0) {
350             # dbversion=0 is an empty database
351 0 0         if ($self->{'verbose'}) { print __x("initialize {filename}\n",
  0            
352             filename => $db_filename); }
353 0           $dbh->do (<<'HERE');
354             CREATE TABLE extra (
355             key TEXT NOT NULL PRIMARY KEY,
356             value TEXT
357             )
358             HERE
359 0           $dbh->do (<<'HERE');
360             CREATE TABLE sent (
361             remote TEXT NOT NULL,
362             filename TEXT NOT NULL,
363             mtime TEXT NOT NULL,
364             size INTEGER NOT NULL,
365             PRIMARY KEY (remote, filename)
366             )
367             HERE
368             }
369              
370 0           $dbh->do ("INSERT OR REPLACE INTO extra (key,value)
371             VALUES ('database-schema-version',?)",
372             undef,
373             $self->DATABASE_SCHEMA_VERSION);
374             }
375              
376              
377             #------------------------------------------------------------------------------
378             sub upfiles {
379 0     0 0   my ($self, %options) = @_;
380              
381 0 0         if (! exists $options{'copy_utime'}) {
382             # default
383 0           $options{'copy_utime'} = 'if_possible';
384             }
385              
386 0 0         if ($self->{'verbose'} >= 3) {
387 0           require Data::Dumper;
388 0           print Data::Dumper->new([\%options],['options'])->Sortkeys(1)->Dump;
389             }
390 0   0       my $local_dir = $options{'local'}
391             // croak __('No local directory specified');
392              
393 0   0       my $remote = $options{'remote'} // croak __('No remote target specified');
394 0           require URI;
395 0 0         if (! eval { require URI::ftps }) {
  0            
396             ### use App-Upfiles-URI-ftps ...
397 0           require App::Upfiles::URI::ftps;
398 0           URI::implementor('ftps','App::Upfiles::URI::ftps');
399             }
400 0 0         my $remote_uri = ($remote =~ /^ftps:/ ? "URI::ftp" : "URI")->new($remote);
401 0           my $remote_dir = $remote_uri->path;
402 0           local $self->{'protocol'} = $remote_uri->scheme;
403 0           local $self->{'host'} = $remote_uri->host;
404 0           local $self->{'username'} = $remote_uri->user;
405 0           local $self->{'remote_dir'} = $remote_dir;
406 0           local $self->{'options'} = \%options;
407              
408 0 0         defined $self->{'username'}
409             or croak __('No username given in remote URL');
410              
411 0 0         if ($self->{'verbose'}) {
412             # TRANSLATORS: any need to translate this? maybe the -> arrow
413             print __x("{localdir} -> {protocol} {username}\@{hostname} {remotedir}\n",
414             localdir => $local_dir,
415             protocol => $self->{'protocol'},
416             username => $self->{'username'},
417 0           hostname => $self->{'host'},
418             remotedir => $remote_dir);
419             }
420              
421             # Go to local directory to notice if it doesn't exist, before attempting
422             # to open/create the database.
423 0 0         chdir $local_dir
424             or croak __x("Cannot chdir to local directory {localdir}: {strerror}",
425             localdir => $local_dir,
426             strerror => "$!");
427              
428 0           my $ftp = $self->ftp;
429             ($ftp->host ($self->{'host'})
430             && $ftp->login ($self->{'username'})
431             && $ftp->binary)
432             or croak __x("{protocol} error on {hostname}: {ftperr}",
433             protocol => $self->{'protocol'},
434 0 0 0       hostname => $self->{'host'},
      0        
435             ftperr => scalar($self->ftp->message));
436              
437 0 0         if ($self->{'recheck'}) {
438 0           $self->recheck();
439 0           return;
440             }
441              
442 0           my $db_filename = File::Spec->catfile ($local_dir, $self->DATABASE_FILENAME);
443 0           my $dbh = $self->dbh ($db_filename);
444              
445             {
446             # initial creation of remote dir
447 0           my ($remote_mtime, $remote_size)
448 0           = $self->db_get_mtime ($dbh, $options{'remote'}, '/');
449 0 0         if (! $remote_mtime) {
450 0           my $unslashed = $remote_dir;
451 0           $unslashed =~ s{/$}{};
452 0 0         if ($self->{'verbose'}) {
453 0           print __x("MKD toplevel {dirname}\n",
454             dirname => $remote_dir);
455             }
456              
457 0 0         unless ($self->{'dry_run'}) {
458 0           $self->ftp_connect;
459 0   0       $self->ftp->mkdir ($unslashed, 1)
460             // croak __x("Cannot make directory {dirname}: {ftperr}",
461             dirname => $remote_dir,
462             ftperr => scalar($self->ftp->message));
463 0           $self->db_set_mtime ($dbh, $options{'remote'}, '/', 1, 1);
464             }
465             }
466             }
467 0           $ftp->cwd ($remote_dir);
468              
469              
470             # =item C (arrayref of regexps)
471             #
472             # Patterns of filenames to sort last for uploading. For example to upload
473             # all index files last
474             #
475             # upfiles (local => '/my/directory',
476             # remote => 'ftp://some-server.org/pub/fred',
477             # sort_last_regexps => [ qr{index\.html$} ]);
478             #
479             # The upload order is all files not "last", then all files matching the
480             # first "last" regexp, then those matching the second "last" regexp, etc.
481             # If a filename matches multiple regexps then the last one it matches is
482             # used for its upload position.
483             #
484             # This option can be used to upload an index, contents list, site map,
485             # etc, after uploads of content it refers to. This suits simple
486             # references (but is probably not enough for mutual dependencies).
487              
488 0           my $local_filenames_hash = $self->local_filenames_hash;
489 0           my $sort_last_regexps = $options{'sort_last_regexps'};
490 0           my @local_filenames = keys %$local_filenames_hash;
491 0           foreach my $filename (@local_filenames) {
492 0           foreach my $i (0 .. $#$sort_last_regexps) {
493             ### $filename
494             ### re: $sort_last_regexps->[$i]
495 0 0         if ($filename =~ $sort_last_regexps->[$i]) {
496 0           $local_filenames_hash->{$filename} = 10 + $i;
497             ### set: 10+$i
498             }
499             }
500             }
501             @local_filenames = sort
502 0 0         {$local_filenames_hash->{$a} <=> $local_filenames_hash->{$b}
  0            
503             || $a cmp $b}
504             @local_filenames;
505              
506 0           my $any_changes = 0;
507 0           foreach my $filename (@local_filenames) {
508              
509             # Reject \r\n here so as to keep any \r\n out of the database.
510             # Don't want to note a \r\n tempfile in the database, have Net::FTP
511             # reject it, and then be left with the database claiming a \r\n file
512             # exists and should be deleted.
513 0 0         if ($filename =~ /[\r\n]/s) {
514 0           croak __x("FTP does not support filenames with CR or LF characters: {filename}",
515             filename => $filename);
516             }
517              
518 0 0         if (my $action_files_hash = $self->{'action_files_hash'}) {
519 0           my $filename_abs = File::Spec->rel2abs($filename);
520             ### $filename_abs
521 0 0         if (! exists $action_files_hash->{$filename_abs}) {
522 0           next;
523             }
524             ### included in action_files_hash ...
525             }
526              
527 0 0         if ($self->{'verbose'} >= 2) {
528 0           print __x("local: {filename}\n", filename => $filename);
529             }
530 0           my $isdir = ($filename =~ m{/$});
531              
532             my ($remote_mtime, $remote_size)
533 0           = $self->db_get_mtime ($dbh, $options{'remote'}, $filename);
534 0   0       my $local_st = File::stat::stat($filename)
535             // next; # if no longer exists
536 0 0         my $local_mtime = ($isdir ? 1 : $local_st->mtime);
537 0 0         my $local_size = ($isdir ? 1 : $local_st->size);
538              
539 0 0         if ($self->{'verbose'} >= 2) {
540 0   0       print " local time=$local_mtime,size=$local_size ",
      0        
541             "remote time=",$remote_mtime//'undef',
542             ",size=",$remote_size//'undef',"\n";
543             }
544              
545 0 0 0       if (defined $remote_mtime && $remote_mtime == $local_mtime
      0        
      0        
546             && defined $remote_size && $remote_size == $local_size) {
547 0 0         if ($self->{'verbose'} >= 2) {
548 0           print __x(" unchanged\n");
549             }
550 0           next;
551             }
552              
553 0 0         unless ($self->{'catchup'}) {
554 0 0         if ($isdir) {
555             # directory, only has to exist
556 0           my $unslashed = $filename;
557 0           $unslashed =~ s{/$}{};
558 0 0         if ($self->{'verbose'}) {
559 0           print __x("MKD {dirname}\n",
560             dirname => $filename);
561             }
562 0           $self->{'change_count'}++;
563 0           $any_changes = 1;
564 0 0         next if $self->{'dry_run'};
565              
566 0           $self->ftp_connect;
567 0   0       $self->ftp->mkdir ($unslashed, 1)
568             // croak __x("Cannot make directory {dirname}: {ftperr}",
569             dirname => $filename,
570             ftperr => scalar($self->ftp->message));
571              
572             } else {
573             # file, must exist and same modtime
574 0           my $size_bytes = -s $filename;
575 0 0         if ($self->{'verbose'}) {
576 0           my $size_kbytes = max (0.1, $size_bytes/1024);
577 0 0         $size_kbytes = sprintf('%.*f',
578             ($size_kbytes >= 10 ? 0 : 1), # decimals
579             $size_kbytes);
580 0           print __x("PUT {filename} [{size_kbytes}k]\n",
581             filename => $filename,
582             size_kbytes => $size_kbytes);
583             }
584 0           $self->{'change_count'}++;
585 0           $self->{'change_size'} += $size_bytes;
586 0           $any_changes = 1;
587 0 0         next if $self->{'dry_run'};
588              
589 0           my $tmpname = "$filename.tmp.$$";
590 0 0         if ($self->{'verbose'} >= 2) {
591 0           print " with tmpname $tmpname\n";
592             }
593 0           $self->db_set_mtime ($dbh, $options{'remote'}, $tmpname,
594             $local_mtime, $local_size);
595              
596             {
597 0           $self->ftp_connect;
  0            
598 0           my $put;
599 0 0         if (my $throttle_options = $options{'throttle'}) {
600 0           require App::Upfiles::Tie::Handle::Throttle;
601 0           require Symbol;
602 0           my $fh = Symbol::gensym();
603 0           tie *$fh, 'App::Upfiles::Tie::Handle::Throttle',
604             %$throttle_options;
605             ### tied: $fh
606             ### tied: tied($fh)
607 0 0         open $fh, '<', $filename
608             or croak __x("Cannot open {filename}: {strerror}",
609             filename => $filename,
610             strerror => $!);
611 0           $put = $self->ftp->put ($fh, $tmpname);
612 0 0         close $fh
613             or croak __x("Error closing {filename}: {strerror}",
614             filename => $filename,
615             strerror => $!);
616             } else {
617 0           $put = $self->ftp->put ($filename, $tmpname);
618             }
619 0 0         $put or croak __x("Error sending {filename}: {ftperr}",
620             filename => $filename,
621             ftperr => scalar($self->ftp->message));
622             }
623              
624 0 0         if ($self->{'verbose'} >= 2) {
625 0           print " rename\n";
626             }
627 0 0         $self->ftp->rename ($tmpname, $filename)
628             or croak __x("Cannot rename {filename}: {ftperr}",
629             filename => $tmpname,
630             ftperr => scalar($self->ftp->message));
631 0           $self->db_delete_mtime ($dbh, $options{'remote'}, $tmpname);
632              
633 0           $self->site_utime($filename, $local_st);
634             }
635             }
636 0           $self->db_set_mtime ($dbh, $options{'remote'}, $filename,
637             $local_mtime, $local_size);
638             }
639              
640             # reverse to delete contained files before their directory ...
641 0           foreach my $filename (reverse db_remote_filenames($dbh, $options{'remote'})) {
642 0 0         next if $local_filenames_hash->{$filename};
643 0 0         if (my $action_files_hash = $self->{'action_files_hash'}) {
644 0 0         if (! exists $action_files_hash->{$filename}) {
645 0           next;
646             }
647             }
648 0           my $isdir = ($filename =~ m{/$});
649              
650 0 0         unless ($self->{'catchup'}) {
651 0 0         if ($isdir) {
652 0           my $unslashed = $filename;
653 0           $unslashed =~ s{/$}{};
654 0 0         if ($self->{'verbose'}) { print __x("RMD {filename}\n",
  0            
655             filename => $filename); }
656 0           $self->{'change_count'}++;
657 0           $any_changes = 1;
658 0 0         next if $self->{'dry_run'};
659              
660 0           $self->ftp_connect;
661 0 0         $self->ftp->rmdir ($unslashed, 1)
662             or warn "Cannot rmdir $unslashed: ", $self->ftp->message;
663              
664             } else {
665 0 0         if ($self->{'verbose'}) { print __x("DELE {filename}\n",
  0            
666             filename => $filename); }
667 0           $self->{'change_count'}++;
668 0           $any_changes = 1;
669 0 0         next if $self->{'dry_run'};
670              
671 0           $self->ftp_connect;
672 0 0         $self->ftp->delete ($filename)
673             or warn "Cannot delete $filename: ", $self->ftp->message;
674             }
675             }
676 0           $self->db_delete_mtime ($dbh, $options{'remote'}, $filename);
677             }
678              
679             $ftp->all_ok
680             or croak __x("ftp error on {hostname}: {ftperr}",
681 0 0         hostname => $self->{'host'},
682             ftperr => scalar($self->ftp->message));
683              
684 0 0         if (! $any_changes) {
685 0 0         if ($self->{'verbose'}) { print ' ',__('no changes'),"\n"; }
  0            
686             }
687              
688 0           return 1;
689             }
690              
691             # $filename is a remote filename.
692             # $local_st is a File::stat of the corresponding local file.
693             #
694             # Set the file modification time on remote $filename to $local_st, using the
695             # method (if any) specified by copy_utime, including possibly testing what
696             # method the server supports (MFMT, SITE UTIME, etc).
697             #
698             # When guessing the method supported on the server, the method found to work
699             # is stored to $options->{'copy_utime'} in order to use the same later
700             # without testing.
701             #
702             sub site_utime {
703 0     0 0   my ($self, $filename, $local_st) = @_;
704 0           my $options = $self->{'options'};
705 0 0         return if ! $options->{'copy_utime'};
706 0 0         return if $self->{'protocol'} eq 'sftp';
707              
708             # MFMT as per https://tools.ietf.org/id/draft-somers-ftp-mfxx-04.txt
709             # MFMT YYYYMMDDhhmmss path
710             # mtime, optional .milliseconds too, not used here
711 0 0 0       if ($options->{'copy_utime'} ne '2arg' && $options->{'copy_utime'} ne '5arg') {
712 0           my $ret = $self->ftp->quot('MFMT',
713             timet_to_ymdhms($local_st->mtime),
714             $filename);
715 0 0         if ($ret == 2) { # OK
716 0           $options->{'copy_utime'} = 'MFMT';
717 0           return 1;
718             }
719              
720             # not OK
721             # If copy_utime==MFMT then it must work,
722             # otherwise anything except 500 not implemented is bad.
723             # 500 not implemented with "if_possible" means keep trying.
724 0           my $code = $self->ftp->code;
725 0 0 0       if ($options->{'copy_utime'} eq 'MFMT' || $code != 500) {
726 0           my $message = $self->ftp->message;
727 0           croak __x("Cannot MFMT {filename}: {ftperr}",
728             filename => $filename,
729             ftperr => $message);
730             }
731             }
732              
733             # SITE UTIME YYYYMMDDhhmm[ss] path
734             # mtime
735             # proftpd style 2-arg
736 0 0 0       if ($options->{'copy_utime'} ne 'MFMT' && $options->{'copy_utime'} ne '5arg') {
737 0           my $ret = $self->ftp->site('UTIME',
738             timet_to_ymdhms($local_st->mtime),
739             $filename);
740 0 0         if ($ret == 2) { # OK
741 0           $options->{'copy_utime'} = '2arg';
742 0           return 1;
743             }
744              
745             # not OK
746             # If copy_utime==2arg then it must work,
747             # otherwise anything except 500 not implemented is bad.
748             # 500 not implemented with "if_possible" means keep trying.
749 0           my $code = $self->ftp->code;
750 0 0 0       if ($options->{'copy_utime'} eq '2arg' || $code != 500) {
751 0           my $message = $self->ftp->message;
752 0           croak __x("Cannot 2-arg SITE UTIME {filename}: {ftperr}",
753             filename => $filename,
754             ftperr => $message);
755             }
756             }
757              
758             # SITE UTIME path YYYYMMDDhhmm[ss] YYYYMMDDhhmm[ss] YYYYMMDDhhmm[ss] UTC
759             # atime, mtime, ctime
760             # pure-ftpd style
761             # pure-ftpd 1.0.33 up has MFMT (and 2-arg SITE UTIME too), but this 5-arg
762             # helps older versions still in use
763 0 0 0       if ($options->{'copy_utime'} ne 'MFMT' && $options->{'copy_utime'} ne '2arg') {
764 0           my $ret = $self->ftp->site('UTIME',
765             $filename,
766             timet_to_ymdhms($local_st->atime),
767             timet_to_ymdhms($local_st->mtime),
768             timet_to_ymdhms($local_st->ctime),
769             "UTC");
770 0 0         if ($ret == 2) { # OK
771 0           $options->{'copy_utime'} = '5arg';
772 0           return 1;
773             }
774              
775             # not OK
776             # If copy_utime==5arg then it must work,
777             # otherwise anything except 500 not implemented is bad.
778             # 500 not implemented with "if_possible" means keep trying.
779 0           my $code = $self->ftp->code;
780 0 0 0       if ($options->{'copy_utime'} eq '5arg' || $code != 500) {
781 0           my $message = $self->ftp->message;
782 0           croak __x("Cannot 5-arg SITE UTIME {filename}: {ftperr}",
783             filename => $filename,
784             ftperr => $message);
785             }
786             }
787              
788 0 0         if ($options->{'copy_utime'} eq 'if_possible') {
789             # SITE UTIME command not available
790 0           $options->{'copy_utime'} = 0;
791 0           print ' ',__('(no SITE UTIME on this server)'),"\n";
792 0           return 0;
793             }
794              
795             # copy_utime is true, meaning must have one of the methods
796 0           croak __("Cannot copy_utime, neither MFMT nor SITE UTIME available on server");
797             }
798              
799             # Return a hashref { $filename => 1 } which is all the local filenames.
800             # "exclude_regexps" etc are applied.
801             # "action_files" etc are not applied, so local_filenames_hash is all local
802             # filenames, of which perhaps only some are to be acted on in this run.
803             #
804             sub local_filenames_hash {
805 0     0 0   my ($self) = @_;
806 0           my $options = $self->{'options'};
807              
808             # $self->{'total_size_kbytes'} = 0;
809             # $self->{'total_count'} = 0;
810              
811 0           my $local_dir = $options->{'local'};
812              
813 0           my @exclude_regexps = (@{$self->{'exclude_regexps_default'}},
814 0   0       @{$options->{'exclude_regexps'} // []});
  0            
815 0 0         if ($self->{'verbose'} >= 3) {
816 0           print "exclude regexps\n";
817 0           foreach my $re (@exclude_regexps) { print " $re\n"; }
  0            
818             }
819              
820 0           my @exclude_basename_regexps = (@{$self->EXCLUDE_BASENAME_REGEXPS_DEFAULT},
821 0   0       @{$options->{'exclude_basename_regexps'}
  0            
822             // []});
823 0 0         if ($self->{'verbose'} >= 3) {
824 0           print "exclude basename regexps\n";
825 0           foreach my $re (@exclude_basename_regexps) { print " $re\n"; }
  0            
826             }
827              
828             # ".upfiles.sqdb" database file
829             # ".upfiles.sqdb-journal" file if interrupted on previous run
830 0           my $database_filename = $self->DATABASE_FILENAME;
831 0           my $database_journal_filename = $database_filename . '-journal';
832              
833 0           my %local_filenames_hash = ('/' => 1);
834             my $wanted = sub {
835 0     0     my $fullname = $File::Find::name;
836 0           my $basename = File::Basename::basename ($fullname);
837              
838 0 0 0       if ($basename eq $database_filename
839             || $basename eq $database_journal_filename) {
840 0           $File::Find::prune = 1;
841 0           return;
842             }
843 0           foreach my $exclude (@{$options->{'exclude'}}) {
  0            
844 0 0         if ($basename eq $exclude) {
845 0           $File::Find::prune = 1;
846 0           return;
847             }
848             }
849 0           foreach my $re (@exclude_basename_regexps) {
850 0 0 0       if (defined $re && $basename =~ $re) {
851 0           $File::Find::prune = 1;
852 0           return;
853             }
854             }
855 0           foreach my $re (@exclude_regexps) {
856 0 0 0       if (defined $re && $fullname =~ $re) {
857 0           $File::Find::prune = 1;
858 0           return;
859             }
860             }
861              
862 0   0       my $st = File::stat::stat($fullname)
863             || croak __x("Cannot stat {filename}: {strerror}",
864             filename => $fullname,
865             strerror => $!);
866 0 0         unless (-d $st) {
867 0           $self->{'total_size_kbytes'} += _bytes_to_kbytes($st->size);
868 0           $self->{'total_count'}++;
869             }
870             ### $fullname
871             ### size: _bytes_to_kbytes($st->size)
872             ### total: $self->{'total_size_kbytes'}
873             ### isdir: -d $st
874              
875 0           my $relname = File::Spec->abs2rel ($fullname, $local_dir);
876 0 0         return if $relname eq '.';
877 0 0         if (-d $fullname) {
878 0           $relname .= '/'; # directory names foo/
879             }
880              
881 0           $local_filenames_hash{$relname} = 1;
882 0           };
883              
884 0           require File::Find;
885             File::Find::find ({ wanted => $wanted,
886             no_chdir => 1,
887 0     0     preprocess => sub { sort @_ },
888             },
889 0           $local_dir);
890              
891 0 0         if ($self->{'verbose'} >= 3) {
892 0           print "local filenames count $self->{'total_count'} total size $self->{'total_size_kbytes'} kbytes\n";
893             }
894              
895             ### %local_filenames_hash
896 0           return \%local_filenames_hash;
897             }
898              
899             sub recheck {
900 0     0 0   my ($self) = @_;
901 0           my $options = $self->{'options'};
902 0           my $local_filenames_hash = $self->local_filenames_hash;
903              
904 0           my $local_dir = $options->{'local'};
905 0           my $db_filename = File::Spec->catfile ($local_dir, $self->DATABASE_FILENAME);
906 0           my $dbh = $self->dbh ($db_filename);
907              
908 0           my $ftp = $self->ftp;
909 0           my $remote_dir = $self->{'remote_dir'};
910 0           my @pending_directories = ('');
911 0           my %seen;
912              
913 0           my %db_filenames = map { $_ => 1 } db_remote_filenames($dbh, $options->{'remote'});
  0            
914             ### %db_filenames
915              
916 0           my $count_remote_extra = 0;
917 0           my $count_remote_missing = 0;
918              
919 0           while (@pending_directories) {
920 0           my $dirname = shift @pending_directories; # depth first
921             ### $dirname
922              
923 0           my $remote_dirname = File::Spec::Unix->catdir($remote_dir, $dirname);
924 0 0         if ($self->{'verbose'} >= 2) {
925 0           print "remote dir $remote_dirname\n";
926             }
927 0           $ftp->cwd($remote_dirname);
928              
929 0           my @lines = $ftp->mlsd(''); # listing of current dir
930             ### @lines
931 0 0         if (! $ftp->ok) {
932 0           print $ftp->message,"\n";
933 0           return;
934             }
935              
936 0           @lines = sort { my ($filename1) = MLSD_line_parse($a);
  0            
937 0           my ($filename2) = MLSD_line_parse($b);
938 0           $filename1 cmp $filename2;
939             } @lines;
940              
941 0           foreach my $line (@lines) {
942 0           my ($filename, %facts) = MLSD_line_parse($line);
943             ### $line
944             ### $filename
945 0   0       my $type = $facts{'type'} // '';
946 0 0         if ($dirname ne '') { $filename = "$dirname/$filename"; }
  0            
947              
948 0 0         if ($type eq 'file') {
    0          
949 0           delete $db_filenames{$filename};
950              
951 0           my $remote_size = $facts{'size'};
952 0 0         if (! defined $remote_size) {
953 0           print __x("{filename} no size from server\n",
954             filename => $filename);
955 0           next;
956             }
957              
958             my ($db_mtime, $db_size)
959 0           = $self->db_get_mtime ($dbh, $options->{'remote'}, $filename);
960 0 0         if (! defined $db_size) {
961 0   0       my $modify = $facts{'modify'} // __('[unknown]');
962 0           print __x("{filename} extra on remote (size {remote_size} modified {modify})\n",
963             filename => $filename,
964             remote_size => $remote_size,
965             modify => $modify);
966 0           $count_remote_extra++;
967 0           next;
968             }
969              
970 0 0         if ($remote_size != $db_size) {
971 0           print __x("{filename} different size (expected {db_size}, remote {remote_size})\n",
972             filename => $filename,
973             db_size => $db_size,
974             remote_size => $remote_size);
975             }
976              
977             } elsif ($type eq 'dir') {
978 0           my $unique = $facts{'unique'};
979 0 0 0       if (defined $unique && $seen{$unique}++) {
980 0           next;
981             }
982 0           push @pending_directories, $filename;
983 0           delete $db_filenames{$filename.'/'};
984             }
985             }
986              
987 0 0         my $dirname_re = ($dirname eq '' ? qr{^[^/]+$} : qr{^\Q$dirname/\E[^/]+$});
988 0           foreach my $filename (sort keys %db_filenames) {
989 0 0         next unless $filename =~ $dirname_re;
990 0           delete $db_filenames{$filename};
991 0 0         if ($filename =~ m{/$}) {
992 0           hash_delete_regexp(\%db_filenames, qr{^\Q$dirname/\E[^/]+/});
993             }
994 0           print __x("{filename} missing on remote\n",
995             filename => $filename);
996 0           $count_remote_missing++;
997             }
998             }
999              
1000 0           print __x("remote extra {count_extra}, missing {count_missing}\n",
1001             count_extra => $count_remote_extra,
1002             count_missing => $count_remote_missing);
1003             }
1004              
1005             # $str is like
1006             # "type=file;size=2061;UNIX.mode=0644; index.html"
1007             # Return a list ($filename, key => value, key => value, ...) which are
1008             # the filename part and the "facts" about it.
1009             # The fact keys are forced to lower case since RFC 3659 specifies them as
1010             # case-insensitive.
1011             sub MLSD_line_parse {
1012 0     0 0   my ($str) = @_;
1013 0 0         $str =~ /(.*?) (.*)$/ or return;
1014 0           my $facts = $1;
1015 0           my $filename = $2;
1016 0           return ($filename, MLST_facts_parse($facts));
1017             }
1018             # $str is the facts part like
1019             # type=file;size=2061;modify=20150304222544;UNIX.mode=0644; index.html
1020             # Return a list (key => value, key => value, ...)
1021             # The fact keys are forced to lower case since RFC 3659 specifies them as
1022             # case-insensitive.
1023             sub MLST_facts_parse {
1024 0     0 0   my ($str) = @_;
1025 0           return map { my ($key, $value) = split /=/, $_, 2;
  0            
1026 0           lc($key) => $value }
1027             split /;/, $str;
1028             }
1029              
1030              
1031             #------------------------------------------------------------------------------
1032             # misc helpers
1033              
1034             # # return size of $filename in kbytes
1035             # sub file_size_kbytes {
1036             # my ($filename) = @_;
1037             # return _bytes_to_kbytes(-s $filename);
1038             # }
1039              
1040             # # return st_mtime (an integer) of $filename, or undef if unable
1041             # sub stat_mtime {
1042             # my ($filename) = @_;
1043             # my $st = File::stat::stat($filename) // return undef;
1044             # return $st->mtime;
1045             # }
1046              
1047             # # $st is a File::stat. Return the disk space occupied by the file, based on
1048             # # the file size rounded up to the next whole block.
1049             # # my $blksize = $st->blksize || 1024;
1050             # sub st_space {
1051             # my ($st) = @_;
1052             # my $blksize = 1024;
1053             # require Math::Round;
1054             # return scalar (Math::Round::nhimult ($blksize, $st->size));
1055             # }
1056              
1057             # $t is a time_t time() style seconds since the epoch.
1058             # Return a string YYYYMMDDHHMMSS in GMT as for MFMT and SITE UTIME.
1059             sub timet_to_ymdhms {
1060 0     0 0   my ($t) = @_;
1061 0           return POSIX::strftime ('%Y%m%d%H%M%S', gmtime($t));
1062             }
1063              
1064             # $t is a time_t time() style seconds since the epoch.
1065             # Return a string like "2001-12-31 23:59:00+00:00" which is the timestamp
1066             # format in the upfiles database.
1067             sub timet_to_timestamp {
1068 0     0 0   my ($t) = @_;
1069 0           return POSIX::strftime ('%Y-%m-%d %H:%M:%S+00:00', gmtime($t));
1070             }
1071             sub timestamp_to_timet {
1072 0     0 0   my ($timestamp) = @_;
1073 0           my ($year, $month, $day, $hour, $minute, $second)
1074             = split /[- :+]/, $timestamp;
1075 0           require Time::Local;
1076 0           return Time::Local::timegm
1077             ($second, $minute, $hour, $day, $month-1, $year-1900);
1078             }
1079              
1080             # $href is a hashref and $re a regexp. Delete all keys matching $re.
1081             sub hash_delete_regexp {
1082 0     0 0   my ($href, $re) = @_;
1083 0           while (my ($key) = each %$href) {
1084 0 0         if ($key =~ $re) {
1085 0           delete $href->{$key};
1086             }
1087             }
1088             }
1089              
1090             1;
1091             __END__