summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--lib/LWP/Protocol/sbo.pm61
-rw-r--r--lib/Net/SBo.pm289
-rw-r--r--lib/SlackBuild/Registry/Backend/FS.pm66
-rw-r--r--lib/URI/sbo.pm37
-rwxr-xr-xslackbuilder24
5 files changed, 449 insertions, 28 deletions
diff --git a/lib/LWP/Protocol/sbo.pm b/lib/LWP/Protocol/sbo.pm
new file mode 100644
index 0000000..676a326
--- /dev/null
+++ b/lib/LWP/Protocol/sbo.pm
@@ -0,0 +1,61 @@
+package LWP::Protocol::sbo;
+use base qw(LWP::Protocol);
+use strict;
+use warnings;
+use File::Temp;
+
+our $VERSION = '1.00';
+
+use HTTP::Request;
+use HTTP::Response;
+use HTTP::Status;
+
+sub request {
+ my ($self, $request, $proxy, $arg, $size) = @_;
+
+ if (defined $proxy) {
+ return HTTP::Response->new(HTTP::Status::RC_BAD_REQUEST,
+ 'You can not proxy through the SBo archive');
+ }
+
+ unless ($request->method eq 'GET') {
+ return HTTP::Response->new(HTTP::Status::HTTP_METHOD_NOT_ALLOWED,
+ "Only GET is allowed for sbo: URLs");
+ }
+
+ my $url = $request->uri;
+ my $scheme = $url;
+ if ($url->scheme ne 'sbo') {
+ return HTTP::Response->new(HTTP::Status::RC_INTERNAL_SERVER_ERROR,
+ __PACKAGE__."::request called for '$scheme'");
+ }
+
+ my $fh = new File::Temp;
+
+ eval {
+ my $sbo = Net::SBo->new;
+ $sbo->get($url->path, $fh->filename, treeish => $url->branch);
+ };
+ if ($@) {
+ return HTTP::Response->new(HTTP::Status::RC_INTERNAL_SERVER_ERROR, $@);
+ }
+
+ my $response = HTTP::Response->new(HTTP::Status::RC_OK);
+ $size = -s $fh;
+ binmode($fh);
+ $response = $self->collect($arg, $response,
+ sub {
+ my $content = "";
+ my $bytes = sysread($fh, $content, $size);
+ return \$content if $bytes > 0;
+ return \ "";
+ });
+ $response->header('Content-Type', 'application/x-tar');
+ $response->header('Content-Length', $size);
+
+ $response;
+}
+
+1;
+
+
diff --git a/lib/Net/SBo.pm b/lib/Net/SBo.pm
new file mode 100644
index 0000000..bc4a3e1
--- /dev/null
+++ b/lib/Net/SBo.pm
@@ -0,0 +1,289 @@
+package Net::SBo;
+use strict;
+use warnings;
+use POSIX::Run::Capture qw(:all);
+use POSIX qw(:sys_wait_h strerror);
+use Carp;
+use File::Basename;
+use File::Spec;
+use File::Path qw(make_path);
+use Archive::Tar;
+
+our $VERSION = '1.00';
+
+=head1 NAME
+
+Net::SBo - Access slackbuilds.org repository
+
+=head1 SYNOPSIS
+
+ use Net::SBo;
+
+ $sbo = new Net::SBo;
+ $sbo = new Net::SBo(dir => $cachedir);
+
+ $path = $sbo->find('mailutils');
+ ($path,$commit) = $sbo->find('mailutils', 'HEAD^');
+
+ $sbo->scan('HEAD^');
+ @files = $sbo->get($path, $dest, %opts);
+
+ $x = $sbo->commit;
+
+=head1 DESCRIPTION
+
+B<Net::SBo> provides access to the L<slackbuilds.org> repository, allowing
+the user to download slackbuild archives for arbitrary packages.
+
+=head1 Object Methods
+
+=head2 Net::SBo->new(%opts)
+
+Returns a new B<SBo> object. A bare mirror of the slackbuilds repository is
+created in the directory B<$HOME/.sbo.git>, unless it already exists, in
+which case it is synchronized with the master repository. Optional keyword
+arguments alter the default settings:
+
+=over 4
+
+=item B<dir>
+
+Name of the local slackbuilds mirror to use.
+
+=item B<repo>
+
+URL of the slackbuilds repository. Default is
+L<git://git.slackbuilds.org/slackbuilds.git>.
+
+=back
+
+If B<dir> is not given, the path to the repository is read from the
+environment variable B<SBO_LOCAL_REPOSITORY>. If it is not set, it
+defaults to B<.sbo.git> in the user home directory.
+
+=cut
+
+my $default_repo = 'git://git.slackbuilds.org/slackbuilds.git';
+
+sub new {
+ my ($class, %args) = @_;
+ my $dir = delete $args{dir}
+ || $ENV{SBO_LOCAL_REPOSITORY}
+ || File::Spec->catfile($ENV{HOME}, '.sbo.git');
+ my $repo = delete $args{repo} || $default_repo;
+
+ my $self = bless {}, $class;
+ my @cmd;
+ if (-d $dir) {
+ @cmd = (qw(git --git-dir), $dir, 'fetch', '-q')
+ } else {
+ @cmd = (qw(git clone -q --mirror), $repo, $dir);
+ }
+ if (@cmd) {
+ if (system(@cmd)) {
+ $self->procdiag($?, @cmd);
+ }
+ }
+ $self->{dir} = $dir;
+ $self->{repo} = $repo;
+
+ return $self;
+}
+
+sub procdiag {
+ my ($self, $status) = (shift, shift);
+ if (WIFEXITED($status)) {
+ return if $status == 0;
+ croak "command \""
+ . join(' ', @_)
+ . "\" terminated with code "
+ . WEXITSTATUS($status);
+ } elsif (WIFSIGNALED($status)) {
+ croak "command \""
+ . join(' ', @_)
+ . "\" terminated on signal "
+ . WTERMSIG($status);
+ } else {
+ croak "command \""
+ . join(' ', @_)
+ . "\" terminated with unrecogized code "
+ . $status;
+ }
+}
+
+=head2 $sbo->scan([$treeish])
+
+Scan the subtree. If I<$treeish> is not given, B<HEAD> is assumed.
+
+Normally, you won't need to use this method, as it is called internally
+when needed.
+
+=cut
+
+sub scan {
+ my ($self, $treeish) = @_;
+ $treeish //= 'HEAD';
+ return if (exists($self->{treeish}) && $self->{treeish} eq 'HEAD');
+ delete $self->{index};
+ delete $self->{treeish};
+ delete $self->{commit};
+
+ my @cmd = ('git', '--git-dir', $self->{dir},
+ qw(ls-tree --full-tree -r --name-only),
+ $treeish);
+ open(my $fh, '-|', @cmd)
+ or croak "git ls-tree failed: $!";
+ while (<$fh>) {
+ chomp;
+ my ($filename, $path, $suffix) = fileparse($_, '.SlackBuild');
+ if ($suffix eq '.SlackBuild') {
+ $self->{index}{$filename} = $path;
+ }
+ }
+ $self->{treeish} = $treeish;
+ # FIXME: Use 'git --git-dir ~/.sbo.git rev-parse $treeish' to convert it
+ # to the SHA.
+}
+
+=head2 $sbo->commit()
+
+Returns the SHA-1 hash identified the scanned commit.
+
+=cut
+
+sub commit {
+ my ($self) = @_;
+ unless ($self->{commit}) {
+ $self->scan;
+ my @cmd = ('git', '--git-dir', $self->{dir}, 'rev-parse',
+ $self->{treeish});
+
+ open(my $fh, '-|', @cmd) or croak "git rev-parse failed: $!";
+ chomp(my @a = <$fh>);
+ $self->{commit} = $a[0];
+ }
+ return $self->{commit};
+}
+
+=head2 $sbo->find($package, [$treeish])
+
+Looks up given package name in the tree. I<$treeish> defaults to B<HEAD>.
+In list context returns B<(I<path>, I<commit>)>, where I<path> is the path
+to the package file in the repository, and I<commit> is the commit id
+corresponding to I<$treeish>. In scalar context, returns path.
+
+If no such package exists, returns empty list in list context and B<undef> in
+scalar context.
+
+=cut
+
+sub find {
+ my ($self, $name, $treeish) = @_;
+ $self->scan($treeish);
+ if (wantarray) {
+ if (exists($self->{index}{$name})) {
+ return ($self->{index}{$name}, $self->commit);
+ } else {
+ return ();
+ }
+ }
+ return $self->{index}{$name}
+}
+
+sub dir_is_empty {
+ my ($self, $dir) = @_;
+ opendir(my $dfh, $dir)
+ or croak "can't open $dir: $!";
+ my $res = 1;
+ while (my $file = readdir $dfh) {
+ next if $file eq '.' or $file eq '..';
+ $res = 0;
+ last;
+ }
+ closedir $dfh;
+ return $res;
+}
+
+=head2 $sbo->get($path, $dest, %opts)
+
+Retrieves files from I<$path>. By default files are enclosed in a tar archive
+which is written to B<$dest>. Options are:
+
+=over 4
+
+=item B<treeish>
+
+Specifies the identifier of the tree to retrieve the files from. Defaults to
+B<HEAD>.
+
+=item B<extract>
+
+If true, the files are extracted from the archive into directory B<$dest>.
+
+=back
+
+Returns names of the retrieved files in list context, and their number in
+scalar context.
+
+=cut
+
+sub get {
+ my ($self, $path, $dest, %args) = @_;
+
+ croak "bad number of arguments" unless defined $dest;
+
+ my $treeish = delete $args{treeish} // 'HEAD';
+ my $extract = delete $args{extract};
+ croak "extra arguments" if keys(%args);
+
+ if ($extract) {
+ if (-d $dest) {
+ croak "$dest is not empty" unless $self->dir_is_empty($dest);
+ } else {
+ croak "$dest exists, but is not a directory" if -e $dest;
+ make_path($dest, {error => \my $err});
+ croak @$err if (@$err);
+ }
+ }
+
+ my @gitcmd = ( 'git', '--git-dir', $self->{dir}, 'archive',
+ $treeish, $path );
+ open(my $fd, '-|', @gitcmd) or croak "can't run git: $!";
+
+ $path .= '/' unless $path =~ m{/$};
+ my $rx = qr($path);
+
+ my $tar = new Archive::Tar($fd);
+ my @result;
+ if ($extract) {
+ $dest .= '/' unless $dest =~ m{/$};
+
+ foreach my $file (tar->get_files) {
+ my $name = $file->full_path;
+ if ($name =~ s{^$rx}{$dest}) {
+ if ($file->extract($name)) {
+ push @result, $name;
+ }
+ }
+ }
+ } else {
+ for (my $comp = $path; $comp ne '.'; $comp = dirname($comp)) {
+ $tar->remove($comp);
+ }
+ foreach my $file ($tar->get_files) {
+ my $name = $file->full_path;
+ if ($name =~ s{^$rx}{}) {
+ $file->rename($name);
+ }
+ push @result, $name;
+ }
+ }
+ close $fd;
+ $self->procdiag($?, @gitcmd);
+ unless ($extract) {
+ $tar->write($dest);
+ }
+ return @result;
+}
+
+1;
diff --git a/lib/SlackBuild/Registry/Backend/FS.pm b/lib/SlackBuild/Registry/Backend/FS.pm
index f71e72a..d7d6918 100644
--- a/lib/SlackBuild/Registry/Backend/FS.pm
+++ b/lib/SlackBuild/Registry/Backend/FS.pm
@@ -16,7 +16,9 @@ SlackBuild::Registry::Backend::FS - filesystem backend for slackbuild registry
=head1 SYNOPSIS
$reg = new SlackBuild::Registry(dir => DIRECTORY);
- my @a = $x->lookup('openssl', version => '1.0.2m');
+ $pat = new SlackBuild::Registry::Pattern(package => 'openssl',
+ version => '1.0.2m');
+ @a = $x->lookup($pat);
=head1 METHODS
@@ -36,33 +38,23 @@ sub new {
croak "required parameter dir not present";
}
croak "too many arguments" if keys %_;
+ $self->scan;
return $self;
}
my @architectures = qw(i386 x86_64 arm noarch);
my @suffixes = qw(.tgz .txz);
-=head2 lookup
-
- @a = $backend->lookup($pattern)
-
-Returns a sorted array of SlackBuild::Registry::Record objects matching the
-B<SlackBuild::Registry::Pattern> object B<$pattern>.
-
-=cut
-
-sub lookup {
- my ($self, $pred) = @_;
- my $pkg = $pred->package;
+sub scan {
+ my $self = shift;
+ my $pat = "*-*-*-*";
- my $pat = "$pkg-*-*-*";
-
- my $rx = '^' . qr($pkg) . '-'
+ my $rx = '^(?<pkg>.+)-'
. '(?<vpfx>.*?)'
. '(?<version>\d+(?:\.\d+)*.*?)'
. '-(?<arch>' . regexp_opt(@architectures) . ')'
. '-(?<build>\d+)(?<rest>[[:punct:]].*)?$';
- my @result = sort {
+ $self->{ls} = [sort {
my $d;
if ($d = ($a->package || '') cmp ($b->package || '')) {
$d
@@ -75,13 +67,12 @@ sub lookup {
($b->build || 1) <=> ($a->build || 1)
}
}
- grep { $pred->matches($_) }
map {
my ($name,$path,$suffix) = fileparse($_, @suffixes);
if ($name =~ m{$rx}) {
my $st = stat($_);
if (S_ISREG($st->mode)) {
- new SlackBuild::Registry::Record($pkg,
+ new SlackBuild::Registry::Record($+{pkg},
version => $+{version},
arch => $+{arch},
build => $+{build},
@@ -93,7 +84,42 @@ sub lookup {
} else {
()
}
- } (glob File::Spec->catfile($self->{dir}, $pat));
+ } (glob File::Spec->catfile($self->{dir}, $pat))];
+
+ $self->{index}{$self->{ls}[0]->package}[0] = 0;
+ my $i;
+ for ($i = 1; $i < @{$self->{ls}}; $i++) {
+ unless ($self->{ls}[$i]->package eq $self->{ls}[$i-1]->package) {
+ $self->{index}{$self->{ls}[$i-1]->package}[1] = $i-1;
+ $self->{index}{$self->{ls}[$i]->package}[0] = $i;
+ }
+ }
+ $self->{index}{$self->{ls}[$i-1]->package}[1] = $i;
+}
+
+=head2 lookup
+
+ @a = $backend->lookup($pattern)
+
+Returns a sorted array of SlackBuild::Registry::Record objects matching the
+B<SlackBuild::Registry::Pattern> object B<$pattern>.
+
+=cut
+
+sub lookup {
+ my ($self, $pred) = @_;
+ my $pkg = $pred->package;
+
+ my @result;
+ if ($pkg) {
+ if (my $idx = $self->{index}{$pkg}) {
+ @result = grep { $pred->matches($_) }
+ @{$self->{ls}}[$idx->[0] .. $idx->[1]];
+ }
+ } else {
+ @result = grep { $pred->matches($_) } @{$self->{ls}};
+ }
+
if (wantarray) {
(@result)
} else {
diff --git a/lib/URI/sbo.pm b/lib/URI/sbo.pm
new file mode 100644
index 0000000..883d659
--- /dev/null
+++ b/lib/URI/sbo.pm
@@ -0,0 +1,37 @@
+package URI::sbo;
+use parent 'URI::_generic';
+
+sub branch {
+ my $self = shift;
+ return $self->authority || 'HEAD';
+}
+
+sub host { shift->branch }
+
+sub path {
+ my $self = shift;
+ my $ret = $self->SUPER::path(@_);
+ $ret =~ s{^/}{};
+ return $ret;
+}
+
+1;
+__END__
+
+=head1 NAME
+
+URI::sbo - slackbuilds URI
+
+=head1 DESCRIPTION
+
+The B<sbo> URIs refer to the packages in the L<git://git.slackbuilds.org/slackbuilds.git> repository. The format of the URI is:
+
+ sbo://TREEISH/PATH
+
+where TREEISH is the git tree identifier, and PATH is the pathname within the
+repository. For example, the following refers to the latest version of
+B<mailutils> package.
+
+ sbo://HEAD/system/mailutils
+
+=cut
diff --git a/slackbuilder b/slackbuilder
index bf4c081..c27d643 100755
--- a/slackbuilder
+++ b/slackbuilder
@@ -6,9 +6,11 @@ use Pod::Usage;
use Pod::Man;
use Getopt::Long qw(:config gnu_getopt no_ignore_case);
use File::Basename;
+use File::Spec;
use Unix::Sysexits;
use SlackBuilder;
use SlackBuild::Request;
+use Net::SBo;
use JSON;
use constant {
@@ -62,17 +64,23 @@ abend(EX_USAGE, "bad number of arguments") unless @ARGV == 1;
my $reqname = shift @ARGV;
my $req;
-unless (-f $reqname) {
- if ($reqname =~ m{(?:http|ftp)s?://.*/
- (.+?) \.tar(?:\.(?:[xgl]z|bz2))?}x) {
- $req = { package => $1, slackbuild_uri => $reqname };
- } else {
- abend(EX_NOINPUT, "request file $reqname does not exist");
- }
-} else {
+if (-f $reqname) {
$req = readfile($reqname);
+} elsif (-d $reqname) {
+ if (my $file = (glob File::Spec->catfile($reqname, '*.SlackBuild'))[0]) {
+ my ($package,$path,$suffix) = fileparse($file, '.SlackBuild');
+ $req = { package => $package, slackbuild_uri => $path };
+ }
+} elsif ($reqname =~ m{^(?:http|ftp)s?://.*/
+ (.+?) \.tar(?:\.(?:[xgl]z|bz2))?}x) {
+ $req = { package => $1, slackbuild_uri => $reqname };
+} elsif (my ($dir,$commit) = Net::SBo->new->find($reqname)) {
+ $req = { package => $reqname, slackbuild_uri => "sbo://$commit/$dir"};
}
+abend(EX_NOINPUT, "request file $reqname does not exist")
+ unless $req;
+
my $builder = new SlackBuilder(%sbargs);
$builder->run(new SlackBuild::Request($req));
if ($builder->is_success) {

Return to:

Send suggestions and report system problems to the System administrator.