/[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.3 by dpavlin, Wed Aug 6 17:55:19 2003 UTC revision 1.6 by dpavlin, Sat Jan 31 18:25:54 2004 UTC
# Line 26  my $REMOTE = "http://cpan.pliva.hr/"; Line 26  my $REMOTE = "http://cpan.pliva.hr/";
26  my $LOCAL = "/rest/cpan/CPAN/";  my $LOCAL = "/rest/cpan/CPAN/";
27    
28  my $TRACE = 0;  my $TRACE = 0;
29  $TRACE = 1 if grep(/-v/,@ARGV);  
30  $TRACE = 1 if grep(/-d/,@ARGV);  # This may or may not save you some disks space (depending on filesystem
31    # that you use to store CPAN mirror)
32    #
33    # If you want to create gziped readme files, change $readme_ext to
34    # my $readme_ext = '.readme.gz';
35    #
36    # I found out that gziping readme files doesn't save any
37    # space at one server and saves space on my laptop. YMMV
38    my $readme_ext = '.readme.gz';
39    
40  ### END CONFIG  ### END CONFIG
41    
# Line 36  use File::Path qw(mkpath); Line 44  use File::Path qw(mkpath);
44  use File::Basename qw(dirname);  use File::Basename qw(dirname);
45  use File::Spec::Functions qw(catfile devnull);  use File::Spec::Functions qw(catfile devnull);
46  use File::Find qw(find);  use File::Find qw(find);
47    use Getopt::Long;
48    use IO::Zlib;
49    
50  ## LWP -  ## LWP -
51  use URI ();  use URI ();
# Line 47  use Compress::Zlib qw(gzopen $gzerrno); Line 57  use Compress::Zlib qw(gzopen $gzerrno);
57  ## Archive::Tar -  ## Archive::Tar -
58  use Archive::Tar qw();  use Archive::Tar qw();
59    
60    ## process command-line arguments
61    my $result = GetOptions(
62            "local=s" => \$LOCAL,
63            "remote=s" => \$REMOTE,
64            "verbose!" => \$TRACE,
65            "debug!" => \$TRACE
66            );
67    
68    print "local path: $LOCAL\nremote URI: $REMOTE\n" if ($TRACE);
69    
70  ## first, get index files  ## first, get index files
71  my_mirror($_) for qw(  my_mirror($_) for qw(
72                       authors/01mailrc.txt.gz                       authors/01mailrc.txt.gz
# Line 120  BEGIN { Line 140  BEGIN {
140    
141    sub clean_unmirrored {    sub clean_unmirrored {
142      find sub {      find sub {
143        return if /\.readme$/; # don't erase readme files        return if /${readme_ext}$/; # don't erase readme files
144        check_readme($File::Find::name);        check_readme($File::Find::name);
145        return unless -f and not $mirrored{$File::Find::name};        return unless -f and not $mirrored{$File::Find::name};
146        print "$File::Find::name ... removed\n" if $TRACE;        print "$File::Find::name ... removed\n" if $TRACE;
147        unlink $_ or warn "Cannot remove $File::Find::name: $!";        unlink $_ or warn "Cannot remove $File::Find::name: $!";
148        my $path = $File::Find::name;        my $path = $File::Find::name;
149        if ($path =~ s/(\.tar\.gz|\.tgz)/.readme/g && -f $path) {        if ($path =~ s/(\.tar\.gz|\.tgz)/${readme_ext}/g && -f $path) {
150          # only if we erase archive also!          # only if we erase archive also!
151          unlink $path or warn "Cannot remove $path: $!";          unlink $path or warn "Cannot remove $path: $!";
152        }        }
# Line 138  BEGIN { Line 158  BEGIN {
158      my $path = shift;      my $path = shift;
159      # fixup some things      # fixup some things
160      my $readme_path = $path;      my $readme_path = $path;
161      $readme_path =~ s/\.(tar\.gz|\.tgz)/.readme/g || return;    # just .tar.gz is supported!      $readme_path =~ s/\.(tar\.gz|\.tgz)/${readme_ext}/g || return;      # just .tar.gz is supported!
162    
163      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";
164    
165      if (! -f $readme_path) {      if (! -f $readme_path) {
166        # create readme file        # create readme file
167        my @readmes = sort grep m{^[^/]+/README\z}, $at->list_files();        my @readmes = sort grep m{^[^/]+/README\z}i, $at->list_files();
168        my $readme;        my $readme;
169    
170        if ($readme = shift @readmes) {        if ($readme = shift @readmes) {
171          open(R, "> $readme_path") || die "Cannot create $readme_path: $!";          my $fh;
172          print R $at->get_content($readme);          if ($readme_ext =~ m/\.gz/) {
173          close(R);                  $fh = IO::Zlib->new($readme_path, "wb");
174            } else {
175                    $fh = IO::File->new($readme_path, "w");
176            }
177            if (defined $fh) {
178                    print $fh $at->get_content($readme);
179                    $fh->close;
180            } else {
181                    die "Cannot create $readme_path: $!";
182            }
183    
184          print "$readme_path ... created\n" if $TRACE;          print "$readme_path ... created\n" if $TRACE;
185    
Legend:
Removed from v.1.3  
changed lines
  Added in v.1.6
  ViewVC Help
Powered by ViewVC 1.1.26