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 |
|
|
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 (); |
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 |
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 |
} |
} |
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 |
|
|