/[perl]/mirror_cpan.pl
This is repository of my old source code which isn't updated any more. Go to git.rot13.org for current projects!
ViewVC logotype

Diff of /mirror_cpan.pl

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.1 by dpavlin, Sat Feb 1 00:40:22 2003 UTC revision 1.5 by dpavlin, Tue Jan 20 19:48:05 2004 UTC
# Line 15  $|++; Line 15  $|++;
15  ### CONFIG  ### CONFIG
16    
17  #my $REMOTE = "http://ftp.linux.hr/CPAN/";  #my $REMOTE = "http://ftp.linux.hr/CPAN/";
18  my $REMOTE = "http://www.cpan.org/";  #my $REMOTE = "http://www.cpan.org/";
19    my $REMOTE = "http://cpan.pliva.hr/";
20  # my $REMOTE = "http://fi.cpan.org/";  # my $REMOTE = "http://fi.cpan.org/";
21  # my $REMOTE = "http://au.cpan.org/";  # my $REMOTE = "http://au.cpan.org/";
22  # my $REMOTE = "file://Users/merlyn/MIRROR/CPAN/";  # my $REMOTE = "file://Users/merlyn/MIRROR/CPAN/";
23    
24  ## warning: unknown files below this dir are deleted!  ## warning: unknown files below this dir are deleted!
25  my $LOCAL = "/mirrors/cpan/CPAN/";  #my $LOCAL = "/mirrors/cpan/CPAN/";
26    my $LOCAL = "/rest/cpan/CPAN/";
27    
28  my $TRACE = 0;  my $TRACE = 0;
29    
# Line 32  use File::Path qw(mkpath); Line 34  use File::Path qw(mkpath);
34  use File::Basename qw(dirname);  use File::Basename qw(dirname);
35  use File::Spec::Functions qw(catfile devnull);  use File::Spec::Functions qw(catfile devnull);
36  use File::Find qw(find);  use File::Find qw(find);
37    use Getopt::Long;
38    use IO::Zlib;
39    
40  ## LWP -  ## LWP -
41  use URI ();  use URI ();
# Line 43  use Compress::Zlib qw(gzopen $gzerrno); Line 47  use Compress::Zlib qw(gzopen $gzerrno);
47  ## Archive::Tar -  ## Archive::Tar -
48  use Archive::Tar qw();  use Archive::Tar qw();
49    
50    ## process command-line arguments
51    my $result = GetOptions(
52            "local=s" => \$LOCAL,
53            "remote=s" => \$REMOTE,
54            "verbose!" => \$TRACE,
55            "debug!" => \$TRACE
56            );
57    
58    print "local path: $LOCAL\nremote URI: $REMOTE\n" if ($TRACE);
59    
60  ## first, get index files  ## first, get index files
61  my_mirror($_) for qw(  my_mirror($_) for qw(
62                       authors/01mailrc.txt.gz                       authors/01mailrc.txt.gz
# Line 116  BEGIN { Line 130  BEGIN {
130    
131    sub clean_unmirrored {    sub clean_unmirrored {
132      find sub {      find sub {
133        return if /\.readme$/; # don't erase readme files        return if /\.readme.gz$/; # don't erase readme files
134        check_readme($File::Find::name);        check_readme($File::Find::name);
135        return unless -f and not $mirrored{$File::Find::name};        return unless -f and not $mirrored{$File::Find::name};
136        print "$File::Find::name ... removed\n" if $TRACE;        print "$File::Find::name ... removed\n" if $TRACE;
137        unlink $_ or warn "Cannot remove $File::Find::name: $!";        unlink $_ or warn "Cannot remove $File::Find::name: $!";
138        my $path = $File::Find::name;        my $path = $File::Find::name;
139        if ($path =~ s/\.tar\.gz/.readme/g && -f $path) {        if ($path =~ s/(\.tar\.gz|\.tgz)/.readme.gz/g && -f $path) {
140          # only if we erase archive also!          # only if we erase archive also!
141          unlink $path or warn "Cannot remove $path: $!";          unlink $path or warn "Cannot remove $path: $!";
142        }        }
# Line 132  BEGIN { Line 146  BEGIN {
146    sub check_readme {    sub check_readme {
147    
148      my $path = shift;      my $path = shift;
   
149      # fixup some things      # fixup some things
150      my $readme_path = $path;      my $readme_path = $path;
151      $readme_path =~ s/\.tar\.gz/.readme/g || return;    # just .tar.gz is supported!      $readme_path =~ s/\.(tar\.gz|\.tgz)/.readme.gz/g || return; # just .tar.gz is supported!
152    
153      my $at = Archive::Tar->new($path) or die "Archive::Tar failed on $path\n";      my $at = Archive::Tar->new($path) or die "Archive::Tar failed on $path\n";
154    
155      if (! -f $readme_path) {      if (! -f $readme_path) {
156        # create readme file        # create readme file
157        my @readmes = sort grep m{^[^/]+/README\z}, $at->list_files();        my @readmes = sort grep m{^[^/]+/README\z}i, $at->list_files();
158        my $readme;        my $readme;
159    
160        if ($readme = shift @readmes) {        if ($readme = shift @readmes) {
161          open(R, "> $readme_path") || die "Cannot create $readme_path: $!";          my $fh = IO::Zlib->new($readme_path, "wb");
162          print R $at->get_content($readme);          if (defined $fh) {
163          close(R);                  print $fh $at->get_content($readme);
164                    $fh->close;
165            } else {
166                    die "Cannot create $readme_path: $!";
167            }
168    
169          print "$readme_path ... created\n" if $TRACE;          print "$readme_path ... created\n" if $TRACE;
170    

Legend:
Removed from v.1.1  
changed lines
  Added in v.1.5

  ViewVC Help
Powered by ViewVC 1.1.26