一个ftp同步的perl程序

hileon

应该是一个老外写的，感觉很不错，贴上来给大家看看，呵呵

1. 
   
2. #!/usr/bin/perl
   
3. use Net::FTP;
   
4. use strict;
   
5. use Getopt::Long;
   
6. 
   
7. # Variables set in the control file.
   
8. #   sync=0|1|fn                        -- Default of the -sync option.
   
9. #   host=hostname                -- Host to send to.
   
10. #   acct=acctname                -- Account name
    
11. #   pwd=password                -- Password to send.
    
12. #   cd=initdir                        -- Initial directory.
    
13. #   
    
14. # The various control options cat be set with lines of the following
    
15. # form:
    
16. #   name = ...                        Set the value.
    
17. #   name += ...                        Add to the value.
    
18. # The value is a list of items, "strint" for a literal match, /str/ for a
    
19. # pattern match.  The available variables are:
    
20. #   send                Matched against local plain files, to transmit.
    
21. #   dontsend                Files maching send which should not be sent.
    
22. #   preserve                Matched against remote files, and
    
23. #                        prevents deletion of remote files not present and sent.
    
24. #   descend                Matches local directory names to descend.
    
25. #   dontdescend                Local directories matched by descend, which should
    
26. #                        not be descended.
    
27. #   presdir                Remote directories to preserve, even though not on
    
28. #                        the descend list.
    
29. 
    
30. # Read the control file.  Info is placed into a hash given as a reference.
    
31. # Initial values are preserved for variables not mentioned, and for +=
    
32. # assignments.  The option required tells if the control file must exist.
    
33. # If required is false, and the file cannot be opened, the function simply
    
34. # returns w/o updating the hash.  If required and will not read, the function
    
35. # dies.  The contents of hasref define the legal variables,
    
36. #   readctl($conn, fn, required, stringargsref, patargsref)
    
37. sub readctl {
    
38.     my $conn = shift @_;
    
39.     my $fn = shift @_;
    
40.     my $req = shift @_;
    
41.     my $strings = shift @_;
    
42.     my $pats = shift @_;
    
43. 
    
44.     if(!open(IN, $fn) && $req) {
    
45.         &expire($conn, "Cannot read $fn");
    
46.     }
    
47. 
    
48.     my $ln;
    
49.     while($ln = <IN>; || shift @_) {
    
50.         # Parse the line and make sure the setting is legal.
    
51.         chomp $ln;
    
52.         $ln or next;
    
53.         $ln =~ /^([a-zA-Z]+)\s*(\=|\+\=)\s*(\S.*)?$/ or
    
54.             &expire($conn, "$fn:$.: Cannot parse");
    
55.         my ($name, $sym, $data) = ($1, $2, $3);
    
56.         exists $strings->;{$name} || exists $pats->;{$name} or
    
57.             &expire($conn, "$fn:$.: Unknown control variable $name.");
    
58.         if($sym eq '+=' && !exists $pats->;{$name}) {
    
59.             &expire($conn, "$fn:$.: Value $name cannot be extended.");
    
60.         }
    
61. 
    
62.         # Update the hash.
    
63.         if(exists $pats->;{$name}) {
    
64.             # Pattern.
    
65.             if($sym eq '=') { $pats->;{$name} = ''; }
    
66.             while($data) {
    
67.                 $pats->;{$name} .= '|' if($pats->;{$name});
    
68.                 my $p;
    
69.                 if($data =~ s|^/(.*?[^\\])/\s*||) {
    
70.                     # Just add a pattern to the list.
    
71.                     $p = $1;
    
72.                 } elsif($data =~ s|^"(.*?[^\\])"\s*||) {
    
73.                     # A string specified.  Make a pattern for exact match.
    
74.                     $p = $1;
    
75.                     $p =~ s/([^a-zA-Z0-9])/\\$1/g;
    
76.                     $p = "^($p)\$";
    
77.                 } else {
    
78.                     &expire($conn, "$fn:$.: Bad match item spec.");
    
79.                 }
    
80. 
    
81.                 # Check for syntax error in the pattern, then add it
    
82.                 # to the whole match pattern.
    
83.                 defined eval("'x' =~ /$p/") or
    
84.                     &expire($conn, "$fn:$.: Bad pattern $p");
    
85.                 $pats->;{$name} .= "($p)";
    
86.             }
    
87.         } else {
    
88.             # Just plain value.
    
89.             $strings->;{$name} = $data;
    
90.         }
    
91.        
    
92.     }
    
93. 
    
94.     close(IN);
    
95. }
    
96. 
    
97. # Options.
    
98. my $norun = 0;
    
99. my $rcfile = ".webserver";
    
100. my $csync = undef;
     
101. GetOptions("n|norun" =>; \$norun, "r|rmtdir|server=s" =>; \$rcfile,
     
102.            "s|sync:s" =>; \$csync);
     
103. $rcfile =~ /^\./ or $rcfile = ".$rcfile";
     
104. 
     
105. # Read the top-level command file.
     
106. my %strings = ( sync =>; 0, host =>; 0, acct =>; 0, pwd =>; 0, cd =>; '');
     
107. my %pats = ( send =>; "(\\.html\$)", preserve =>; "", descend =>; "(.)",
     
108.              presdir =>; "", dontsend =>; "", dontdescend =>; "" );
     
109. readctl(0, $rcfile, 1, \%strings, \%pats, @ARGV);
     
110. if(defined $csync) {
     
111.     # From command line.
     
112.     if($csync eq '') { $csync = 1; }
     
113.     $strings{"sync"} = $csync;
     
114. }
     
115. if($strings{"sync"} == 1) { $strings{"sync"} == 'syncfile'; }
     
116. 
     
117. #foreach my $n(keys %strings) { print "strings{$n} = $strings{$n}\n"; }
     
118. #print "\n";
     
119. #foreach my $n(keys %pats) { print "pats{$n} = $pats{$n}\n"; }
     
120. #print "\n";
     
121. 
     
122. # Time offset.
     
123. my $syncoff = 0;
     
124. 
     
125. # Close and maybe exit.
     
126. my $was_err = 0;
     
127. sub expire {
     
128.     my $conn = shift @_;
     
129.     my $msg = shift @_;
     
130.     my ($fatal) = (@_, 1);
     
131. 
     
132.     my $err = '';
     
133.     if($conn) {
     
134.         $err = $conn->;message();
     
135.     }
     
136.     chomp $err;
     
137.     $err =~ s/\.\s*$//;
     
138.     $msg =~ s/\!\!/$err/;
     
139.     print "$msg.\n";
     
140.     if($fatal) {
     
141.         $conn->;quit() if $conn;
     
142.         exit(2);
     
143.     } else {
     
144.         $was_err = 1;
     
145.     }
     
146. }
     
147. 
     
148. # Read the curr directory on the server, and return a pair of hash references.
     
149. # The first is to a hash giving the name and mod date of each ordinary file,
     
150. # and the second gives the directories, with value 1.
     
151. sub rmt_contents {
     
152.     my $conn = shift @_;
     
153.     my %files = ();
     
154.     my %dirs = ();
     
155.     my $nttime = '\d\d\-\d\d\-\d\d\s+\d\d\:\d\d[AP]M';
     
156. 
     
157.     my @names = $conn->;dir();
     
158.     int($conn->;code() / 100) == 2 or
     
159.         expire($conn, "Remote list failed: !!");
     
160.     foreach my $l(@names) {
     
161.         chomp $l;
     
162.         my ($name, $isdir);
     
163.         if($l =~ /^[\-d]([\-r][\-w][\-xs]){2}[\-r][\-w][\-xt]\s/) {
     
164.             # Smells like Unix (inoring specials, etc.)
     
165.             my ($mode, $links, $uid, $gid, $size, $d1, $d2, $d3, $n) =
     
166.                 split(/\s+/, $l, 9);
     
167.             $name = $n;
     
168.             $isdir = ($l =~ /^d/);
     
169.         } elsif($l =~ /^$nttime\s+(\<(DIR)\>;\s+|\d+\s)(.*)$/) {
     
170.             # Smells NT
     
171.             $name = $3;
     
172.             $isdir = ($2 eq 'DIR');
     
173.         } else {
     
174.             # Can't figure it out, or its the wrong kind of thing.
     
175.             next;
     
176.         }
     
177.         if($isdir) {
     
178.             next if $name eq '.' || $name eq '..';
     
179.             $dirs{"$name"} = 1;
     
180.         } else {
     
181.             my $time = $conn->;mdtm($name);
     
182.             $files{"$name"} = $time + $syncoff;
     
183.         }
     
184.     }
     
185.     return (\%files, \%dirs);
     
186. }
     
187. 
     
188. # Read the curr local directory, and return a pair of references.
     
189. # The first is to a hash giving the name and mod dat of each ordinary file,
     
190. # and the second is to an array of directory names in the current directory.
     
191. # The function ignores any file starting with ., and obeys the send,
     
192. # dontsend, descend and dontdescend patterns.  That means that files which
     
193. # don't match send, or do match dontsend, are ignored.  Likewise directories
     
194. # not matchind descend or matching dontdescend are not reported.  
     
195. sub loc_contents {
     
196.     my $conn = shift @_; # Only for aborts.
     
197.     my $strref = shift @_;
     
198.     my $pref = shift @_;
     
199. 
     
200.     my %files = ();
     
201.     my %dirs = ();
     
202. 
     
203.     opendir(CD, '.') or expire($conn, "Directory open failed: $!");
     
204.     while(my $name = readdir(CD))
     
205.     {
     
206.         next if($name =~ /^\./);
     
207.         if(-f $name) {
     
208.             if(!$pref->;{"send"} || $name !~ /$pref->;{"send"}/) { next; }
     
209.             if($pref->;{"dontsend"} && $name =~ /$pref->;{"dontsend"}/) {
     
210.                 next;
     
211.             }
     
212.             my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime)
     
213.                 = stat($name);
     
214.             $files{"$name"} = $mtime;
     
215.         } elsif(-d $name) {
     
216.             if(!$pref->;{"descend"} || $name !~ /$pref->;{"descend"}/) {
     
217.                 next;
     
218.             }
     
219.             if($pref->;{"dontdescend"} &&
     
220.                $name =~ /$pref->;{"dontdescend"}/) {
     
221.                 next;
     
222.             }
     
223.             $dirs{"$name"} = 1;
     
224.         }
     
225.     }
     
226.     closedir(CD);
     
227.     return (\%files, \%dirs);
     
228. }
     
229. 
     
230. # Delete all contents of the current remote directory, with the given name.
     
231. sub delrmt {
     
232.     my $conn = shift @_;
     
233.     my $name = shift @_;
     
234. 
     
235.     # Get the contents.
     
236.     my ($files, $dirs) = rmt_contents($conn);
     
237. 
     
238.     # Get rid of the files.
     
239.     foreach my $fi(keys %$files) {
     
240.         print "Deleting $name$fi.\n";
     
241.         if(!$norun) {
     
242.             $conn->;delete($fi) or
     
243.                 expire($conn, "Delete $name$fi failed: !!", 0);
     
244.         }
     
245.     }
     
246. 
     
247.     # Get rid of the directories.
     
248.     foreach my $d(keys %$dirs) {
     
249.         $conn->;cwd($d) or expire($conn, "cd $name$d failed: !!");
     
250.         delrmt($conn, "$name$d/");
     
251.         $conn->;cdup() or expire($conn, "cd up failed: !!");
     
252.         print "Removing directory $name$d.\n";
     
253.         if(!$norun) {
     
254.             $conn->;rmdir($d) or expire($conn, "rmdir $name$d failed: !!", 0);
     
255.         }
     
256.     }
     
257. }
     
258. 
     
259. # Synchronize.
     
260. sub sync {
     
261.     my $conn = shift @_;
     
262.     my $name = shift @_;
     
263.     my $fn = shift @_;
     
264.     my $strings = shift @_;
     
265.     my $pats = shift @_;
     
266. 
     
267.     # Get the contents.
     
268.     my ($rfiles, $rdirs) = rmt_contents($conn);
     
269.     my ($lfiles, $ldirs) = loc_contents($conn,$strings,$pats);
     
270. 
     
271.     #print "FRED $name:\n"; prfl($lfiles);
     
272.     #print "\n";
     
273.     #prfl($ldirs);
     
274.     #print "\n";
     
275. 
     
276.     # Go through the local files and put what needs putting.
     
277.     foreach my $lf(keys %$lfiles) {
     
278.         # See if it must be sent.
     
279.         if(!exists $rfiles->;{$lf} || $rfiles->;{$lf} < $lfiles->;{$lf}) {
     
280.             # Old or missing....
     
281.             print "Sending $name$lf\n";
     
282.             if(!$norun) {
     
283.                 if(!-r $lf) {
     
284.                     expire($conn, "File $lf is not readable", 0);
     
285.                 } else {
     
286.                     $conn->;put($lf) or
     
287.                         expire($conn, "Put $name$lf failed: !!", 0);
     
288.                 }
     
289.             }
     
290.         }
     
291.         delete $rfiles->;{$lf};
     
292.     }
     
293. 
     
294.     # If there are any remote files left, delete them.
     
295.     foreach my $rf(keys %$rfiles) {
     
296.         next if ($pats->;{"preserve"} && ($rf =~ /$pats->;{"preserve"}/));
     
297.         print "Deleting $name$rf.\n";
     
298.         if(!$norun) {
     
299.             $conn->;delete($rf) or
     
300.                 expire($conn, "Delete $name$rf failed: !!", 0);
     
301.         }
     
302.     }
     
303. 
     
304.     # Recur on the local directory names.
     
305.     foreach my $ld(keys %$ldirs) {
     
306.         # Create if needed.
     
307.         if(!$rdirs->;{$ld}) {
     
308.             print "Creating $name$ld\n";
     
309.             if($norun) {
     
310.                 print "Sending $name$ld subtree.\n";
     
311.                 next;
     
312.             } else {
     
313.                 if(!$conn->;mkdir($ld)) {
     
314.                     expire($conn, "Create $name$ld failed: !!", 0);
     
315.                     next;
     
316.                 }
     
317.             }
     
318.         }
     
319. 
     
320.         # Perform the recursion.
     
321.         $conn->;cwd($ld) or expire($conn, "cd $name$ld failed: !!");
     
322.         chdir($ld) or expire($conn, "local cd $ld failed: $!");
     
323.         if(-r $fn) {
     
324.             my %nstrings = %$strings;
     
325.             my %npats = %$pats;
     
326.             readctl($conn, $fn, 0, \%nstrings, \%npats);
     
327.             sync($conn, "$name$ld/", $fn, \%nstrings, \%npats);
     
328.         } else {
     
329.             sync($conn, "$name$ld/", $fn, $strings, $pats);
     
330.         }
     
331.         $conn->;cdup() or expire($conn, "cd up failed: !!");
     
332.         chdir('..') or expire($conn, "local cd .. failed: $!");
     
333. 
     
334.         delete $rdirs->;{$ld};
     
335.     }
     
336. 
     
337.     # Wipe remotes not matched locally.
     
338.     foreach my $rd(keys %$rdirs) {
     
339.         next if($pats->;{"presdir"} && ($rd =~ /$pats->;{"presdir"}/));
     
340.         $conn->;cwd($rd) or expire($conn, "cd $name$rd failed: !!");
     
341.         delrmt($conn, "$name$rd/");
     
342.         $conn->;cdup() or expire($conn, "cd up failed: !!");
     
343.         print "Removing directory $name$rd.\n";
     
344.         if(!$norun) {
     
345.             $conn->;rmdir($rd) or
     
346.                 expire($conn, "Removal of $name$rd failed: !!", 0);
     
347.         }
     
348.     }
     
349. }
     
350. 
     
351. # Print the file times map.
     
352. sub prfl {
     
353.     my $hr = shift @_;
     
354. 
     
355.     foreach my $k(sort keys %$hr) {
     
356.         my $mod = localtime($hr->;{$k});
     
357.         print "$k->;$mod\n";
     
358.     }
     
359. }
     
360. 
     
361. # Synchronize clocks.
     
362. sub clocksync {
     
363.     my $conn = shift @_;
     
364.     my $fn = shift @_;
     
365. 
     
366.     if(! -f $fn) {
     
367.         open(SF, ">;$fn") or
     
368.             expire($conn, "Cannot create $fn for time sync option");
     
369.         close(SF);
     
370.     }
     
371.     -z $fn or
     
372.         expire($conn, "File $fn for time sync must be empty.");
     
373. 
     
374.     $conn->;put($fn) or
     
375.         expire($conn, "$fn send failed: !!");
     
376. 
     
377.     my $now_here = time();
     
378.     my $now_there = $conn->;mdtm($fn) or
     
379.         expire($conn, "Cannot get $fn write time");
     
380. 
     
381.     #print "FRED: $now_here $now_there\n";
     
382.     #print "FRED: ", localtime($now_here), " ", localtime($now_there), "\n";
     
383. 
     
384.     $syncoff = $now_here - $now_there;
     
385.     $syncoff -= 5; # Be a bit conservative.
     
386. 
     
387.     #print "A: [$now_here] [$now_there] [$syncoff]\n";
     
388. 
     
389.     $conn->;delete($fn);
     
390.    
     
391.     my $hrs = int($syncoff/3600);
     
392.     my $mins = int($syncoff/60) - $hrs*60;
     
393.     my $secs = $syncoff - $hrs*3600 - $mins*60;
     
394.     printf("Clock sync offset: %d:%02d:%02d\n", $hrs, $mins, $secs);
     
395. }
     
396. 
     
397. # Check for login info.
     
398. $strings{"host"} && $strings{"acct"} && $strings{"pwd"} or
     
399.     die "Hostname, account name, and password must be specified.\n";
     
400. 
     
401. # Do the communications.
     
402. my $conn = Net::FTP->;new($strings{"host"}, Passive =>; 1) or
     
403.     die "Connect: $@\n";
     
404. $conn->;login($strings{"acct"}, $strings{"pwd"}) or
     
405.     expire($conn, "Login as $strings{'acct'} failed: !!");
     
406. if($strings{"cd"}) {
     
407.     $conn->;cwd($strings{"cd"}) or
     
408.         expire($conn, "Initial directory change failed: !!");
     
409. }
     
410. $conn->;binary() or
     
411.     expire($conn, "Binary mode failed: !!");
     
412. 
     
413. # Optional clock synchronization step.
     
414. if($strings{"sync"}) { clocksync($conn, $strings{"sync"}); }
     
415. 
     
416. #my ($a, $b) = rmt_contents($conn);
     
417. #print "files:\n";
     
418. #prfl($a);
     
419. #print "dirs:\n";
     
420. #prfl($b);
     
421. 
     
422. # Now the real work.
     
423. sync($conn, '', $rcfile, \%strings, \%pats);
     
424. 
     
425. $conn->;quit();
     
426. 
     
427. exit $was_err;
     

复制代码