Initial commit
This commit is contained in:
eleksir
22
LICENSE
Normal file
22
LICENSE
Normal file
@@ -0,0 +1,22 @@
|
||||
Copyright 2010 Sergei Fedosov <eleksir@gmail.com>
|
||||
|
||||
Redistribution and use in source and binary forms, with or without
|
||||
modification, are permitted provided that the following conditions are met:
|
||||
|
||||
1. Redistributions of source code must retain the above copyright notice, this
|
||||
list of conditions and the following disclaimer.
|
||||
|
||||
2. Redistributions in binary form must reproduce the above copyright notice,
|
||||
this list of conditions and the following disclaimer in the documentation
|
||||
and/or other materials provided with the distribution.
|
||||
|
||||
THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
|
||||
AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
|
||||
IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
|
||||
DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE
|
||||
FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
|
||||
DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
|
||||
SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
|
||||
CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
|
||||
OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
|
||||
OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
|
||||
71
README.md
Normal file
71
README.md
Normal file
@@ -0,0 +1,71 @@
|
||||
# RPM Repositories Cloning tool
|
||||
|
||||
1 to 1 rpm cloning tool
|
||||
|
||||
## Getting Started
|
||||
|
||||
rrclone http://source/repo/ /absolute/path/to/destination/folder/
|
||||
|
||||
### Prerequisites
|
||||
|
||||
Linux or FreeBSD with recent perl (at least 5.20, on previous versions i didn't
|
||||
test it). There is no external packages required in order to run this program.
|
||||
The only thing that required is Perl. But many linux distributions have
|
||||
ill-minded practice to rip Perl into many sub-packages, in this case you have
|
||||
to install some perl packages.
|
||||
|
||||
for ubuntu: libjson-pp-perl, libfile-spec-perl, libxml-parser-perl,
|
||||
libio-compress-perl, liburi-perl
|
||||
|
||||
in case of Slackware Linux everything is already shipped with single Perl
|
||||
package.
|
||||
|
||||
```
|
||||
apt install libjson-pp-perl, libfile-spec-perl, libxml-parser-perl,
|
||||
libio-compress-perl, liburi-perl
|
||||
```
|
||||
|
||||
### Installing
|
||||
|
||||
There are no additional effort required for one-shot sync.
|
||||
|
||||
But if you planning to keep repository in sync with upstream, you should add
|
||||
cron job, that can be run without any additional privileges, i.e. web server
|
||||
user is enough for that.
|
||||
|
||||
to add cronjob invoke
|
||||
|
||||
```
|
||||
su -s /bin/bash apache
|
||||
crontab -e
|
||||
```
|
||||
|
||||
```
|
||||
30 4 * * 0 /path/to/rrclone http://repository/url/ /absolute/path/to/copy/
|
||||
```
|
||||
|
||||
This will run job weekly, at Sunday 4:30.
|
||||
|
||||
## Deployment
|
||||
|
||||
Obviously, before deploy this script on some production environment you should
|
||||
package it properly :)
|
||||
|
||||
## Contributing
|
||||
|
||||
If you want contribute ideas or code - please feel free to contact me via
|
||||
email eleksir at exs-elm.ru
|
||||
|
||||
## Authors
|
||||
|
||||
* **Eleksir** - *Initial work* - [exs' corner](https://exs-elm.ru/hg/rrclone)
|
||||
|
||||
## License
|
||||
|
||||
This project is licensed under the BSD License - see the [LICENSE](LICENSE) file for details
|
||||
|
||||
## Acknowledgments
|
||||
|
||||
* Hat tip to anyone whose code was used
|
||||
* Inspiration
|
||||
* you
|
||||
19
TODO
Normal file
19
TODO
Normal file
@@ -0,0 +1,19 @@
|
||||
Технический долг и планируемые доработки.
|
||||
|
||||
* внедрить GetOpt, чтобы корректно парсить аргументы ком.строки стандартными средствами. Для этого нужно будет использовать внешние по отношению к Perl модули, GetOpt и GetOpt::Long
|
||||
* XML::Simple умеет работать не только с деревом, но и с потоком xml, в случае с потоком должно потребляться меньше памяти, но работать с ним сложнее
|
||||
* добавить возможность работы с sqlite-метаданными и перейти на этот метод по-умолчанию
|
||||
* добавить пример spec-файла
|
||||
* добавить пример debian package
|
||||
* добавить slackbuild
|
||||
* добавить ebuild
|
||||
* добавить примеры crontab
|
||||
* добавить man page
|
||||
* добавить методики работы с https://packagecloud.io/ и сервисами подобными им (без автоиндекса)
|
||||
|
||||
Факультативное задание :)
|
||||
* добавить возможность клонирования deb-репозиториев
|
||||
* добавить возможность клонирования ещё каких-нибудь репозиториев, навроде apt-rpm
|
||||
* добавить возможность исключения пакетов по регулярке (по подстроке, хотябы)
|
||||
* добавить возможность перегенерации метаданных, по фэн-шую (описать этот фэн-шуй в документации)
|
||||
|
||||
325
rrclone
Normal file
325
rrclone
Normal file
@@ -0,0 +1,325 @@
|
||||
#!/usr/bin/perl
|
||||
#
|
||||
# simple RPM Repository cloning script
|
||||
|
||||
# looks like some toxic ditribution polices for ill-driven distros like debian|ubuntu or less shitty like centos
|
||||
# make maintainers split std. perl (and python too) distribution to many-many packages, even meta packages like
|
||||
# perl-modules for ubuntu contain not full set of default perl source distribution' modules, so you have to install
|
||||
# some packages in order to work with this script
|
||||
#
|
||||
# for ubuntu: libjson-pp-perl, libfile-spec-perl, libxml-parser-perl, libio-compress-perl, liburi-perl
|
||||
# for slackware - everything is bundled with builtin perl :)
|
||||
|
||||
use strict;
|
||||
use warnings "all";
|
||||
use Fcntl;
|
||||
use File::Basename;
|
||||
use File::Path qw(make_path);
|
||||
use File::Spec;
|
||||
use XML::Parser;
|
||||
use IO::Zlib;
|
||||
use URI::URL;
|
||||
#use Data::Dumper;
|
||||
|
||||
sub dlfunc(@);
|
||||
sub urlencode($);
|
||||
sub getmetadata();
|
||||
sub help($);
|
||||
sub path_normalize_by_string_manipulation($);
|
||||
sub getfilenames($);
|
||||
sub noslash($);
|
||||
|
||||
help(0) unless (defined $ARGV[0]);
|
||||
help(1) unless (defined $ARGV[1]);
|
||||
|
||||
help(0) if ($ARGV[0] eq '--help');
|
||||
help(0) if ($ARGV[0] eq '-h');
|
||||
|
||||
my $noclean = 0;
|
||||
|
||||
if (defined($ARGV[0]) and $ARGV[0] eq '--noclean') {
|
||||
$noclean = 1;
|
||||
}
|
||||
|
||||
my $BASEURL = $ARGV[0];
|
||||
my $BASEDIR = $ARGV[1];
|
||||
|
||||
if ($noclean == 1) {
|
||||
help(1) unless (defined $ARGV[2]);
|
||||
$BASEURL = $ARGV[1];
|
||||
$BASEDIR = $ARGV[2];
|
||||
}
|
||||
|
||||
noslash($BASEURL);
|
||||
noslash($BASEDIR);
|
||||
|
||||
my @REPOFILES;
|
||||
my @FILES;
|
||||
|
||||
my $primaryxmlgz = getmetadata();
|
||||
my $fh = new IO::Zlib;
|
||||
my $xmldata = '';
|
||||
|
||||
if ($fh->open($BASEDIR . $primaryxmlgz, "rb")) {
|
||||
|
||||
while (<$fh>) {
|
||||
$xmldata .= $_;
|
||||
}
|
||||
|
||||
$fh->close;
|
||||
} else {
|
||||
syswrite STDERR, sprintf("An error has occured while reading %s.", $BASEDIR . 'repodata/primary.xml.gz');
|
||||
exit 1;
|
||||
}
|
||||
|
||||
my $p1 = new XML::Parser(Style => 'Tree');
|
||||
my $ref = $p1->parse($xmldata);
|
||||
undef $xmldata;
|
||||
my @array = @{ $ref->[1] };
|
||||
|
||||
for (my $i = 0; $i < @array; $i++) {
|
||||
|
||||
if (defined($array[$i]) and ($array[$i] eq 'package')) {
|
||||
$i++;
|
||||
my @array2 = @{ $array[$i] };
|
||||
my $size = -1;
|
||||
my $link;
|
||||
|
||||
for (my $j = 0; $j < @array2; $j++) {
|
||||
|
||||
if (defined($array2[$j]) and ($array2[$j] eq 'size')) {
|
||||
$j++;
|
||||
$size = $array2[$j][0]{'package'};
|
||||
}
|
||||
|
||||
if (defined($array2[$j]) and ($array2[$j] eq 'location')) {
|
||||
$j++;
|
||||
$link = $array2[$j][0]{'href'};
|
||||
# syswrite STDOUT, "+ " . $array2[$j][0]{'href'} . "\n";
|
||||
}
|
||||
|
||||
}
|
||||
|
||||
dlfunc($link, $size);
|
||||
undef $size;
|
||||
undef $link;
|
||||
@array2 = -1;
|
||||
}
|
||||
}
|
||||
|
||||
exit 0 if ($noclean == 1);
|
||||
|
||||
my $searchpath = $BASEDIR;
|
||||
chop $searchpath;
|
||||
getfilenames($searchpath);
|
||||
my @filesToDelete;
|
||||
|
||||
foreach my $fileOnDisk (@FILES) {
|
||||
my $flag = 0;
|
||||
|
||||
foreach my $fileInXML (@REPOFILES) {
|
||||
if ($fileInXML eq $fileOnDisk) {
|
||||
$flag = 1;
|
||||
last;
|
||||
}
|
||||
}
|
||||
|
||||
if ($flag == 0) {
|
||||
push @filesToDelete, $fileOnDisk;
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
foreach my $file (@filesToDelete) {
|
||||
unless (-d $file) {
|
||||
unlink $file;
|
||||
}
|
||||
}
|
||||
|
||||
exit 0;
|
||||
|
||||
sub help($) {
|
||||
my $rc = shift;
|
||||
my $help = <<'HELP';
|
||||
Usage: cr.pl [--noclean] source destination
|
||||
|
||||
Where
|
||||
--noclean is optional argument, if it specified, no cleanup operation will
|
||||
be performed after rpm downloading complete.
|
||||
|
||||
Source must be http(s) url which trimmed at repodata folder. If full url is
|
||||
http://mirror.yandex.ru/centos/7.4.1708/os/x86_64/repodata/repomd.xml
|
||||
source must be given as:
|
||||
http://mirror.yandex.ru/centos/7.4.1708/os/x86_64/
|
||||
|
||||
Destination is the folder where all files and metadata will be downloaded, if
|
||||
folder does not exist it will be created. Must contain trailng slash char.
|
||||
For example:
|
||||
/var/www/htdocs/repo/
|
||||
HELP
|
||||
|
||||
syswrite STDOUT, $help;
|
||||
exit $rc;
|
||||
}
|
||||
|
||||
sub dlfunc(@) {
|
||||
my $url = shift; # short (relative) URL without BASE part
|
||||
my $size = shift;
|
||||
my $wgetpath;
|
||||
my $savepath = path_normalize_by_string_manipulation ($BASEDIR . $url);
|
||||
|
||||
if (substr($savepath, 0, length($BASEDIR)) ne $BASEDIR) {
|
||||
syswrite STDERR, sprintf("Skipping package %s, because it out of destdir %s, looks like quirky metadata.\n", $savepath, $BASEDIR);
|
||||
return;
|
||||
}
|
||||
|
||||
push @REPOFILES, $savepath;
|
||||
|
||||
# do not re-download already downloaded rpm packages
|
||||
unless ($size == -1) {
|
||||
|
||||
if (-f $savepath) {
|
||||
my $filesize = (stat($savepath))[7];
|
||||
|
||||
if ($size == $filesize) {
|
||||
return;
|
||||
}
|
||||
}
|
||||
|
||||
}
|
||||
|
||||
my $basedir; (undef, $basedir) = fileparse($savepath);
|
||||
|
||||
unless (-d $basedir) {
|
||||
my $ret = make_path ($basedir);
|
||||
|
||||
if ($ret < 1) {
|
||||
syswrite STDERR, sprintf("Unable to create directory %s .\n", $basedir);
|
||||
exit 1;
|
||||
}
|
||||
}
|
||||
|
||||
if (-f "/bin/wget") {
|
||||
$wgetpath = '/bin/wget';
|
||||
} elsif (-f "/usr/bin/wget") {
|
||||
$wgetpath = '/usr/bin/wget';
|
||||
} elsif (-f "/usr/local/bin/wget") {
|
||||
$wgetpath = '/usr/local/bin/wget';
|
||||
} else {
|
||||
syswrite STDERR, "Please install wget. (Unable to find it in std locations)\n";
|
||||
exit 1;
|
||||
}
|
||||
|
||||
$url = $BASEURL . $url;
|
||||
$url = urlencode($url);
|
||||
system($wgetpath, '--no-check-certificate', '-q', '-T', '20', '-O', $savepath, '-o', '/dev/null', $url);
|
||||
|
||||
undef $savepath;
|
||||
undef $url;
|
||||
}
|
||||
|
||||
sub urlencode($) {
|
||||
my $url = shift;
|
||||
my $urlobj = url $url;
|
||||
$url = $urlobj->as_string;
|
||||
undef $urlobj;
|
||||
return $url;
|
||||
}
|
||||
|
||||
sub getmetadata() {
|
||||
dlfunc('repodata/repomd.xml', -1);
|
||||
|
||||
my $p1 = new XML::Parser(Style => 'Tree');
|
||||
my $ref = $p1->parsefile($BASEDIR . 'repodata/repomd.xml');
|
||||
|
||||
#print Dumper $ref->[1][8][12][0]{'href'};
|
||||
# must be 'data'-------^
|
||||
# must be 'location'------^
|
||||
|
||||
my @array = @{ $ref->[1] };
|
||||
my $primaryxmlgz;
|
||||
|
||||
for (my $i = 0; $i < @array; $i++) {
|
||||
|
||||
if (defined($array[$i]) and ($array[$i] eq 'data')){
|
||||
$i++;
|
||||
my @array2 = @{ $array[$i] };
|
||||
|
||||
for (my $j = 0; $j < @array2; $j++) {
|
||||
if (defined($array2[$j]) and ($array2[$j] eq 'location')) {
|
||||
$j++;
|
||||
dlfunc($array2[$j][0]{'href'}, -1);
|
||||
|
||||
if ($array2[$j][0]{'href'} =~ /primary\.xml\.gz$/) {
|
||||
$primaryxmlgz = $array2[$j][0]{'href'};
|
||||
}
|
||||
}
|
||||
|
||||
}
|
||||
|
||||
@array2 = -1;
|
||||
}
|
||||
|
||||
}
|
||||
|
||||
return $primaryxmlgz;
|
||||
}
|
||||
|
||||
sub path_normalize_by_string_manipulation ($) {
|
||||
my $path = shift;
|
||||
|
||||
# canonpath does string manipulation, but does not remove "..".
|
||||
my $ret = File::Spec->canonpath($path);
|
||||
|
||||
# Let's remove ".." by using a regex.
|
||||
while ($ret =~ s{
|
||||
(^|/) # Either the beginning of the string, or a slash, save as $1
|
||||
( # Followed by one of these:
|
||||
[^/]| # * Any one character (except slash, obviously)
|
||||
[^./][^/]| # * Two characters where
|
||||
[^/][^./]| # they are not ".."
|
||||
[^/][^/][^/]+ # * Three or more characters
|
||||
) # Followed by:
|
||||
/\.\./ # "/", followed by "../"
|
||||
}{$1}x
|
||||
) {
|
||||
# Repeat this substitution until not possible anymore.
|
||||
}
|
||||
|
||||
# Re-adding the trailing slash, if needed.
|
||||
if ($path =~ m!/$! && $ret !~ m!/$!) {
|
||||
$ret .= '/';
|
||||
}
|
||||
|
||||
return $ret;
|
||||
}
|
||||
|
||||
sub getfilenames($) {
|
||||
my $path = shift;
|
||||
|
||||
opendir (DIR, $path) or return "";
|
||||
my @localfiles;
|
||||
@localfiles =
|
||||
map { $path . '/' . $_ }
|
||||
grep { !/^\.{1,2}$/ }
|
||||
readdir (DIR);
|
||||
@FILES = (@FILES, @localfiles);
|
||||
|
||||
foreach (@localfiles) {
|
||||
next if(-l $_);
|
||||
|
||||
if( -d $_){
|
||||
getfilenames($_);
|
||||
}
|
||||
}
|
||||
|
||||
}
|
||||
|
||||
sub noslash($) {
|
||||
my $str = shift;
|
||||
return if ($str =~ /\/$/);
|
||||
syswrite STDERR, "Source and destination must have trailing slashes!\n";
|
||||
exit 1;
|
||||
}
|
||||
|
||||
__END__
|
||||
403
rrclone-mt
Normal file
403
rrclone-mt
Normal file
@@ -0,0 +1,403 @@
|
||||
#!/usr/bin/perl
|
||||
# simple RPM Repository cloning script
|
||||
|
||||
# looks like some toxic ditribution polices for ill-driven distros like debian|ubuntu or less shitty like centos
|
||||
# make maintainers split std. perl (and python too) distribution to many-many packages, even meta packages like
|
||||
# perl-modules for ubuntu contain not full set of default perl source distribution' modules, so you have to install
|
||||
# some packages in order to work with this script
|
||||
#
|
||||
# for ubuntu: libjson-pp-perl, libfile-spec-perl, libxml-parser-perl, libio-compress-perl, liburi-perl
|
||||
# for slackware - everything is bundled with builtin perl :)
|
||||
|
||||
# TODO: use another model of xml processing to use less memory
|
||||
|
||||
use strict;
|
||||
use warnings "all";
|
||||
use Fcntl;
|
||||
use threads;
|
||||
use threads::shared;
|
||||
use File::Basename;
|
||||
use File::Path qw(make_path);
|
||||
use File::Spec;
|
||||
use XML::Parser;
|
||||
use IO::Zlib;
|
||||
use URI::URL;
|
||||
use Data::Dumper;
|
||||
use HTTP::Tiny;
|
||||
use IO::Socket::SSL; # implicit requirement in order to HTTP::Tiny work with https
|
||||
|
||||
sub mythread();
|
||||
sub dlfunc(@);
|
||||
sub urlencode($);
|
||||
sub getmetadata();
|
||||
sub help($);
|
||||
sub path_normalize_by_string_manipulation($);
|
||||
sub getfilenames($);
|
||||
sub noslash($);
|
||||
sub dbg($);
|
||||
|
||||
help(0) unless (defined $ARGV[0]);
|
||||
help(1) unless (defined $ARGV[1]);
|
||||
|
||||
help(0) if ($ARGV[0] eq '--help');
|
||||
help(0) if ($ARGV[0] eq '-h');
|
||||
|
||||
my $noclean = 0;
|
||||
my $DEBUG = 0;
|
||||
|
||||
if (defined($ARGV[0]) and $ARGV[0] eq '--noclean') {
|
||||
$noclean = 1;
|
||||
}
|
||||
|
||||
my $BASEURL = $ARGV[0];
|
||||
my $BASEDIR = $ARGV[1];
|
||||
|
||||
if ($noclean == 1) {
|
||||
help(1) unless (defined $ARGV[2]);
|
||||
$BASEURL = $ARGV[1];
|
||||
$BASEDIR = $ARGV[2];
|
||||
}
|
||||
|
||||
noslash($BASEURL);
|
||||
noslash($BASEDIR);
|
||||
|
||||
syswrite STDOUT, sprintf("Cloning %s to %s\n", $BASEURL, $BASEDIR);
|
||||
|
||||
my @REPOFILES :shared;
|
||||
my @FILES;
|
||||
my @LINKS :shared;
|
||||
my @SIZES :shared;
|
||||
my $MUTEX :shared = 0; # while $MUTEX = 1, noone picks links
|
||||
|
||||
my $primaryxmlgz = getmetadata();
|
||||
my $fh = new IO::Zlib;
|
||||
my $xmldata = '';
|
||||
|
||||
if ($fh->open($BASEDIR . $primaryxmlgz, "rb")) {
|
||||
|
||||
while (<$fh>) {
|
||||
$xmldata .= $_;
|
||||
}
|
||||
|
||||
$fh->close;
|
||||
} else {
|
||||
syswrite STDERR, sprintf("An error has occured while reading %s.", $BASEDIR . 'repodata/primary.xml.gz');
|
||||
exit 1;
|
||||
}
|
||||
|
||||
my $p1 = new XML::Parser(Style => 'Tree');
|
||||
my $ref = $p1->parse($xmldata);
|
||||
undef $xmldata;
|
||||
my @array = @{ $ref->[1] };
|
||||
|
||||
for (my $i = 0; $i < @array; $i++) {
|
||||
|
||||
if (defined($array[$i]) and ($array[$i] eq 'package')) {
|
||||
$i++;
|
||||
my @array2 = @{ $array[$i] };
|
||||
my $size = -1;
|
||||
my $link;
|
||||
|
||||
for (my $j = 0; $j < @array2; $j++) {
|
||||
|
||||
if (defined($array2[$j]) and ($array2[$j] eq 'size')) {
|
||||
$j++;
|
||||
$size = $array2[$j][0]{'package'};
|
||||
}
|
||||
|
||||
if (defined($array2[$j]) and ($array2[$j] eq 'location')) {
|
||||
$j++;
|
||||
$link = $array2[$j][0]{'href'};
|
||||
}
|
||||
|
||||
}
|
||||
|
||||
push @LINKS, $link;
|
||||
push @SIZES, $size;
|
||||
|
||||
undef $size;
|
||||
undef $link;
|
||||
@array2 = -1;
|
||||
}
|
||||
}
|
||||
|
||||
@array = -1;
|
||||
undef $p1;
|
||||
|
||||
for (my $i = 1; $i < 4; $i++) {
|
||||
threads->create('mythread');
|
||||
}
|
||||
|
||||
my $tcount = 0;
|
||||
|
||||
do {
|
||||
$tcount = threads->list();
|
||||
|
||||
foreach my $thread (threads->list(threads::joinable)) {
|
||||
$thread->join();
|
||||
}
|
||||
|
||||
# list of threads can be polled once per second, it delays consecutive polls by one second
|
||||
sleep(3);
|
||||
} while ($tcount > 0);
|
||||
|
||||
undef $tcount;
|
||||
syswrite STDOUT, "Cloning done.\n";
|
||||
exit 0 if ($noclean == 1);
|
||||
|
||||
syswrite STDOUT, sprintf("Cleaning old files in %s\n", $BASEDIR);
|
||||
|
||||
my $searchpath = $BASEDIR;
|
||||
chop $searchpath;
|
||||
getfilenames($searchpath);
|
||||
my @filesToDelete;
|
||||
|
||||
foreach my $fileOnDisk (@FILES) {
|
||||
my $flag = 0;
|
||||
|
||||
foreach my $fileInXML (@REPOFILES) {
|
||||
if ($fileInXML eq $fileOnDisk) {
|
||||
$flag = 1;
|
||||
last;
|
||||
}
|
||||
}
|
||||
|
||||
if ($flag == 0) {
|
||||
push @filesToDelete, $fileOnDisk;
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
while (@filesToDelete > 0) {
|
||||
my $file = pop(@filesToDelete);
|
||||
|
||||
unless (-d $file) {
|
||||
dbg(" - Unlinking $file");
|
||||
unlink $file;
|
||||
}
|
||||
}
|
||||
|
||||
syswrite STDOUT, "Cleaning done.\n";
|
||||
exit 0;
|
||||
|
||||
sub help($) {
|
||||
my $rc = shift;
|
||||
my $help = <<'HELP';
|
||||
Usage: cr.pl [--noclean] http://source/url/ /destination/dir/
|
||||
|
||||
Where
|
||||
--noclean is optional argument, if it specified, no cleanup operation will
|
||||
be performed after rpm downloading complete.
|
||||
|
||||
Source must be http(s) url which trimmed at repodata folder. If full url is
|
||||
http://mirror.yandex.ru/centos/7.4.1708/os/x86_64/repodata/repomd.xml
|
||||
source must be given as:
|
||||
http://mirror.yandex.ru/centos/7.4.1708/os/x86_64/
|
||||
|
||||
Destination is the folder where all files and metadata will be downloaded, if
|
||||
folder does not exist it will be created. Must contain trailng slash char.
|
||||
For example:
|
||||
/var/www/htdocs/repo/
|
||||
HELP
|
||||
|
||||
syswrite STDOUT, $help;
|
||||
exit $rc;
|
||||
}
|
||||
|
||||
sub mythread() {
|
||||
while ( 1 ) {
|
||||
my $size;
|
||||
my $link;
|
||||
|
||||
if ($MUTEX == 0) {
|
||||
$MUTEX = 1;
|
||||
$size = pop(@SIZES);
|
||||
$link = pop(@LINKS);
|
||||
$MUTEX = 0;
|
||||
} else {
|
||||
# pop from 2 arrays takes very small amount of time,
|
||||
# in practice we do not need this micro-sleep
|
||||
# select(undef, undef, undef, 0.05);
|
||||
next;
|
||||
}
|
||||
|
||||
if (@LINKS > 0) {
|
||||
if ((defined($size)) and (defined($link))) {
|
||||
dlfunc($link, $size);
|
||||
}
|
||||
} else {
|
||||
# handle last package in list
|
||||
if ((defined($size)) and (defined($link))) {
|
||||
dlfunc($link, $size);
|
||||
} else {
|
||||
last;
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
sub dlfunc(@) {
|
||||
my $url = shift; # short (relative) URL without BASE part
|
||||
my $size = shift;
|
||||
my $wgetpath;
|
||||
my $savepath = path_normalize_by_string_manipulation ($BASEDIR . $url);
|
||||
|
||||
if (substr($savepath, 0, length($BASEDIR)) ne $BASEDIR) {
|
||||
syswrite STDERR, sprintf("Skipping package %s, because it out of destdir %s, looks like quirky metadata.\n", $savepath, $BASEDIR);
|
||||
return;
|
||||
}
|
||||
|
||||
push @REPOFILES, $savepath;
|
||||
|
||||
# do not re-download already downloaded rpm packages
|
||||
unless ($size == -1) {
|
||||
|
||||
if (-f $savepath) {
|
||||
my $filesize = (stat($savepath))[7];
|
||||
|
||||
if ($size == $filesize) {
|
||||
dbg(" * Skip $savepath file already exists and on-disk and in-repo sizes are match.");
|
||||
return;
|
||||
} else {
|
||||
dbg(" + Downloading $savepath file exists but on-disk and in-repo sizes are mismatch. $filesize vs $size.")
|
||||
}
|
||||
} else {
|
||||
dbg(" + Downloading $savepath");
|
||||
}
|
||||
|
||||
}
|
||||
|
||||
my $basedir; (undef, $basedir) = fileparse($savepath);
|
||||
|
||||
unless (-d $basedir) {
|
||||
my $ret = make_path ($basedir);
|
||||
|
||||
if ($ret < 1) {
|
||||
syswrite STDERR, sprintf("Unable to create directory %s .\n", $basedir);
|
||||
exit 1;
|
||||
}
|
||||
}
|
||||
|
||||
$url = $BASEURL . $url;
|
||||
$url = urlencode($url);
|
||||
|
||||
my $http = HTTP::Tiny->new();
|
||||
$http->mirror($url, $savepath);
|
||||
undef $http;
|
||||
|
||||
undef $savepath;
|
||||
undef $url;
|
||||
}
|
||||
|
||||
sub urlencode($) {
|
||||
my $url = shift;
|
||||
my $urlobj = url $url;
|
||||
$url = $urlobj->as_string;
|
||||
undef $urlobj;
|
||||
return $url;
|
||||
}
|
||||
|
||||
sub getmetadata() {
|
||||
dlfunc('repodata/repomd.xml', -1);
|
||||
|
||||
my $p1 = new XML::Parser(Style => 'Tree');
|
||||
my $ref = $p1->parsefile($BASEDIR . 'repodata/repomd.xml');
|
||||
|
||||
#print Dumper $ref->[1][8][12][0]{'href'};
|
||||
# must be 'data'-------^
|
||||
# must be 'location'------^
|
||||
|
||||
my @array = @{ $ref->[1] };
|
||||
my $primaryxmlgz;
|
||||
|
||||
for (my $i = 0; $i < @array; $i++) {
|
||||
|
||||
if (defined($array[$i]) and ($array[$i] eq 'data')){
|
||||
$i++;
|
||||
my @array2 = @{ $array[$i] };
|
||||
|
||||
for (my $j = 0; $j < @array2; $j++) {
|
||||
if (defined($array2[$j]) and ($array2[$j] eq 'location')) {
|
||||
$j++;
|
||||
dlfunc($array2[$j][0]{'href'}, -1);
|
||||
|
||||
if ($array2[$j][0]{'href'} =~ /primary\.xml\.gz$/) {
|
||||
$primaryxmlgz = $array2[$j][0]{'href'};
|
||||
}
|
||||
}
|
||||
|
||||
}
|
||||
|
||||
@array2 = -1;
|
||||
}
|
||||
|
||||
}
|
||||
|
||||
@array = -1;
|
||||
return $primaryxmlgz;
|
||||
}
|
||||
|
||||
sub path_normalize_by_string_manipulation ($) {
|
||||
my $path = shift;
|
||||
|
||||
# canonpath does string manipulation, but does not remove "..".
|
||||
my $ret = File::Spec->canonpath($path);
|
||||
|
||||
# Let's remove ".." by using a regex.
|
||||
while ($ret =~ s{
|
||||
(^|/) # Either the beginning of the string, or a slash, save as $1
|
||||
( # Followed by one of these:
|
||||
[^/]| # * Any one character (except slash, obviously)
|
||||
[^./][^/]| # * Two characters where
|
||||
[^/][^./]| # they are not ".."
|
||||
[^/][^/][^/]+ # * Three or more characters
|
||||
) # Followed by:
|
||||
/\.\./ # "/", followed by "../"
|
||||
}{$1}x
|
||||
) {
|
||||
# Repeat this substitution until not possible anymore.
|
||||
}
|
||||
|
||||
# Re-adding the trailing slash, if needed.
|
||||
if ($path =~ m!/$! && $ret !~ m!/$!) {
|
||||
$ret .= '/';
|
||||
}
|
||||
|
||||
return $ret;
|
||||
}
|
||||
|
||||
sub getfilenames($) {
|
||||
my $path = shift;
|
||||
|
||||
opendir (DIR, $path) or return "";
|
||||
my @localfiles =
|
||||
map { $path . '/' . $_ }
|
||||
grep { !/^\.{1,2}$/ }
|
||||
readdir (DIR);
|
||||
@FILES = (@FILES, @localfiles);
|
||||
|
||||
foreach (@localfiles) {
|
||||
next if(-l $_);
|
||||
|
||||
if(-d $_){
|
||||
getfilenames($_);
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
sub noslash($) {
|
||||
my $str = shift;
|
||||
return if ($str =~ /\/$/);
|
||||
syswrite STDERR, "Source and destination must have trailing slashes!\n";
|
||||
exit 1;
|
||||
}
|
||||
|
||||
sub dbg($) {
|
||||
my $msg = shift;
|
||||
|
||||
if ($DEBUG) {
|
||||
syswrite STDOUT, "$msg\n";
|
||||
}
|
||||
}
|
||||
|
||||
__END__
|
||||
Reference in New Issue
Block a user