diff options
-rw-r--r-- | lib/LWP/Protocol/sbo.pm | 61 | ||||
-rw-r--r-- | lib/Net/SBo.pm | 289 | ||||
-rw-r--r-- | lib/SlackBuild/Registry/Backend/FS.pm | 66 | ||||
-rw-r--r-- | lib/URI/sbo.pm | 37 | ||||
-rwxr-xr-x | slackbuilder | 24 |
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) { |