OpenPKG Specs: openpkg/search.pl@a2c6460cfb16 (annotated)

openpkg/search.pl@a2c6460cfb16 (annotated)

openpkg/search.pl

Mon, 28 Jan 2013 17:37:18 +0100

author: Michael Schloh von Bennewitz <michael@schloh.com>
date: Mon, 28 Jan 2013 17:37:18 +0100
changeset 758: a2c6460cfb16
permissions: -rw-r--r--

Correct socket error reporting improvement with IPv6 portable code,
after helpful recommendation by Saúl Ibarra Corretgé on OSips devlist.

 ##
 ##  search.pl -- OpenPKG Package Searching
 ##  Copyright (c) 2011-2012 OpenPKG GmbH <http://openpkg.com/>
 ##
 ##  This software is property of the OpenPKG GmbH, DE MUC HRB 160208.
 ##  All rights reserved. Licenses which grant limited permission to use,
 ##  copy, modify and distribute this software are available from the
 ##  OpenPKG GmbH.
 ##
 ##  THIS SOFTWARE IS PROVIDED "AS IS" AND ANY EXPRESSED 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 AUTHORS AND COPYRIGHT HOLDERS AND THEIR
 ##  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.
 ##
 require 5.003;
 #   OpenPKG instance prefix and RPM
 my $my_prefix = $ENV{'OPENPKG_PREFIX'};
 my $my_rpm = "$my_prefix/bin/openpkg rpm";
 delete $ENV{'OPENPKG_PREFIX'};
 #   program identification
 my $progname  = "search";
 my $progvers  = "0.1.0";
 #   home-brewn getopt(3) style option parser
 sub getopts ($$@) {
     my ($opt_spec, $opts, @argv_orig) = @_;
     my (%optf) = map { m/(\w)/; $1 => $_ } $opt_spec =~ m/(\w:|\w)/g;
     my (@argv, $optarg);
     foreach (@argv_orig) {
         if (@argv) {
             push @argv, $_;
         } elsif (defined $optarg) {
             if (exists $opts->{$optarg}) {
                 $opts->{$optarg} .= " $_";
             } else {
                 $opts->{$optarg} = $_;
             }
             $optarg = undef;
         } elsif (!/^[-]/) {
             push @argv, $_;
         } else {
             while (/^\-(\w)(.*)/) {
                 if (exists $optf{$1}) {
                     if (length($optf{$1}) > 1) {
                         if ($2 ne '') {
                             if (exists $opts->{$1}) {
                                 $opts->{$1} .= " $2";
                             } else {
                                 $opts->{$1} = $2;
                             }
                         } else {
                             $optarg = $1;
                         }
                         last;
                     } else {
                         $opts->{$1} = 1;
                     }
                 } else {
                     warn "openpkg:$prog_name:WARNING: unknown option $_\n";
                 }
                 $_ = "-$2";
             }
         }
     }
     if (defined $optarg) {
         warn "openpkg:$prog_name:WARNING: option $optarg requires an argument\n";
     }
     foreach my $opt (keys %optf) {
         if (not exists $opts->{$opt}) {
             $opts->{$opt} = (length($optf{$opt}) > 1 ? "" : 0);
         }
     }
     return @argv;
 }
 #   execute a command
 my $run_cache = {};
 sub run ($) {
     my ($cmd) = @_;
     my $out = $run_cache->{$cmd};
     if (not defined($out)) {
         my @out = `$cmd`;
         $out = [ @out ];
         $run_cache->{$cmd} = $out;
     }
     return (wantarray ? @{$out} : join(//, @{$out}));
 }
 #   determine reasonable temporary directory
 my $tmpdir = ($ENV{"TMPDIR"} || "/tmp");
 #   parse command line options
 my $opts = {};
 @ARGV = getopts("hvr:", $opts, @ARGV);
 #   usage sanity check and usage help
 sub usage {
     my ($rc) = @_;
     my $usage = "openpkg:$prog_name:USAGE: openpkg search <regex>\n";
     if ($rc == 0) {
         print STDOUT $usage;
     }
     else {
         print STDERR $usage;
     }
     exit($rc);
 }
 if ($opts->{"h"}) {
     usage(0);
 }
 if (@ARGV == 0) {
     usage(1);
 }
 #   take command line arguments
 my $keyword = $ARGV[0];
 #   determine start URL
 my $url = $opts->{"r"} || "";
 if ($url eq "") {
     $url = run("$my_prefix/bin/openpkg release --fmt='%u' 2>/dev/null");
     $url =~ s/^\s+//s;
     $url =~ s/\s+$//s;
 }
 if ($url eq "") {
     print STDERR "openpkg:$prog_name:ERROR: no repository URL known\n";
     exit(1);
 }
 #   recursively download XML/RDF index
 sub relurl ($$) {
     my ($url, $suburl) = @_;
     if ($suburl =~ m/^\w+:\/\//) {
         $url = $suburl;
     }
     elsif ($suburl =~ m/^\//) {
         $url = "file://$suburl";
     }
     else {
         $url =~ s/(\/)?\/*[^\/]*$/$1$suburl/;
     }
 while ($url =~ s/\/\.\//\//s);
 while ($url =~ s/\/[^\/]+\/\.\.\//\//s);
     return $url;
 }
 sub get_index ($) {
     my ($url) = @_;
     if ($url =~ m/^\//) {
         $url = "file://$url";
     }
     if ($url =~ m/\/$/) {
         $url .= "00INDEX.rdf";
     }
     my $cmd = "$my_prefix/bin/openpkg curl -s -o- \"$url\" 2>/dev/null";
     if ($url =~ m/\.bz2$/) {
         $cmd .= " | $my_prefix/lib/openpkg/bzip2 -d -c";
     }
     my $xml = run($cmd);
     my @includes = ();
     while ($xml =~ m/<Repository\s+[^>]*href="([^"]*)"/gs) {
         push(@includes, $1);
     }
     foreach my $include (@includes) {
         $xml .= get_index(relurl($url, $include));
     }
     return $xml;
 }
 my $xml = get_index($url);
 #   parse XML/RDF index
 my $x = $xml;
 $x =~ s/<rdf:Description\s+about="([^"]+)".*?>(.+?)<\/rdf:Description>/do1($1, $2), ''/sge;
 sub do1 {
     my ($nvr, $xml) = @_;
     my ($name) = ($xml =~ m|<Name>(.+?)</Name>|s);
     my ($vers) = ($xml =~ m|<Version>(.+?)</Version>|s);
     my ($rele) = ($xml =~ m|<Release>(.+?)</Release>|s);
     my ($summ) = ($xml =~ m|<Summary>(.+?)</Summary>|s);
     my ($desc) = ($xml =~ m|<Description>(.+?)</Description>|s);
     if (   $name =~ m|$keyword|si
         or $summ =~ m|$keyword|si
         or $desc =~ m|$keyword|si) {
         do2($nvr, $name, $vers, $rele, $summ, $desc, $xml);
     }
 }
 sub do2 {
     my ($nvr, $name, $vers, $rele, $summ, $desc, $xml) = @_;
     return if ($name eq "openpkg");
     if ($opts->{"v"}) {
         #   itemized verbose output
         my ($dist)     = ($xml =~ m|<Distribution>(.+?)</Distribution>|s);
         my ($class)    = ($xml =~ m|<Class>(.+?)</Class>|s);
         my ($group)    = ($xml =~ m|<Group>(.+?)</Group>|s);
         my ($license)  = ($xml =~ m|<License>(.+?)</License>|s);
         my ($packager) = ($xml =~ m|<Packager>(.+?)</Packager>|s);
         my ($url)      = ($xml =~ m|<URL>(.+?)</URL>|s);
         my ($vendor)   = ($xml =~ m|<Vendor>(.+?)</Vendor>|s);
         print "Name:     $name\n";
         print "Version:  $vers\n";
         print "Release:  $rele\n";
         print "Group:    $group\n";
         print "Class:    $class\n";
         print "Distrib:  $dist\n";
         print "License:  $license\n";
         print "Packager: $packager\n";
         print "Vendor:   $vendor\n";
         print "Summary:  $summ\n";
         print "URL:      $url\n";
         print "Description:\n";
         $desc =~ s/^\s+//mg;
         $desc =~ s/\s+$//mg;
         $desc =~ s/^/    /mg;
         print "$desc\n";
         my ($prov) = ($xml =~ m|<Provides>(.+?)</Provides>|s);
         if (($prov || "") ne "") {
             print "Provides:\n";
             $prov =~ s/<resource\s+equ="([^"]*)">(.+?)<\/resource>/do3($1, $2), ''/sge;
             sub do3 {
                 my ($val, $name) = @_;
                 print "    $name = $val\n";
             }
         }
         print "\n";
     }
     else {
         #   tabular brief output
         printf("%-20s %-10s %-9s %s\n", $name, $vers, $rele, $summ);
     }
 }

OpenPKG Specs / annotate

openpkg/search.pl@a2c6460cfb16 (annotated)

openpkg/search.pl