OpenPKG Specs: openpkg/search.pl@a2c6460cfb16

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

     1 ##

     2 ##  search.pl -- OpenPKG Package Searching

     3 ##  Copyright (c) 2011-2012 OpenPKG GmbH <http://openpkg.com/>

     4 ##

     5 ##  This software is property of the OpenPKG GmbH, DE MUC HRB 160208.

     6 ##  All rights reserved. Licenses which grant limited permission to use,

     7 ##  copy, modify and distribute this software are available from the

     8 ##  OpenPKG GmbH.

     9 ##

    10 ##  THIS SOFTWARE IS PROVIDED "AS IS" AND ANY EXPRESSED OR IMPLIED

    11 ##  WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF

    12 ##  MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED.

    13 ##  IN NO EVENT SHALL THE AUTHORS AND COPYRIGHT HOLDERS AND THEIR

    14 ##  CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,

    15 ##  SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT

    16 ##  LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF

    17 ##  USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND

    18 ##  ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,

    19 ##  OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT

    20 ##  OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF

    21 ##  SUCH DAMAGE.

    22 ##

    24 require 5.003;

    26 #   OpenPKG instance prefix and RPM

    27 my $my_prefix = $ENV{'OPENPKG_PREFIX'};

    28 my $my_rpm = "$my_prefix/bin/openpkg rpm";

    29 delete $ENV{'OPENPKG_PREFIX'};

    31 #   program identification

    32 my $progname  = "search";

    33 my $progvers  = "0.1.0";

    35 #   home-brewn getopt(3) style option parser

    36 sub getopts ($$@) {

    37     my ($opt_spec, $opts, @argv_orig) = @_;

    38     my (%optf) = map { m/(\w)/; $1 => $_ } $opt_spec =~ m/(\w:|\w)/g;

    39     my (@argv, $optarg);

    41     foreach (@argv_orig) {

    42         if (@argv) {

    43             push @argv, $_;

    44         } elsif (defined $optarg) {

    45             if (exists $opts->{$optarg}) {

    46                 $opts->{$optarg} .= " $_";

    47             } else {

    48                 $opts->{$optarg} = $_;

    49             }

    50             $optarg = undef;

    51         } elsif (!/^[-]/) {

    52             push @argv, $_;

    53         } else {

    54             while (/^\-(\w)(.*)/) {

    55                 if (exists $optf{$1}) {

    56                     if (length($optf{$1}) > 1) {

    57                         if ($2 ne '') {

    58                             if (exists $opts->{$1}) {

    59                                 $opts->{$1} .= " $2";

    60                             } else {

    61                                 $opts->{$1} = $2;

    62                             }

    63                         } else {

    64                             $optarg = $1;

    65                         }

    66                         last;

    67                     } else {

    68                         $opts->{$1} = 1;

    69                     }

    70                 } else {

    71                     warn "openpkg:$prog_name:WARNING: unknown option $_\n";

    72                 }

    73                 $_ = "-$2";

    74             }

    75         }

    76     }

    77     if (defined $optarg) {

    78         warn "openpkg:$prog_name:WARNING: option $optarg requires an argument\n";

    79     }

    80     foreach my $opt (keys %optf) {

    81         if (not exists $opts->{$opt}) {

    82             $opts->{$opt} = (length($optf{$opt}) > 1 ? "" : 0);

    83         }

    84     }

    85     return @argv;

    86 }

    88 #   execute a command

    89 my $run_cache = {};

    90 sub run ($) {

    91     my ($cmd) = @_;

    92     my $out = $run_cache->{$cmd};

    93     if (not defined($out)) {

    94         my @out = `$cmd`;

    95         $out = [ @out ];

    96         $run_cache->{$cmd} = $out;

    97     }

    98     return (wantarray ? @{$out} : join(//, @{$out}));

    99 }

   101 #   determine reasonable temporary directory

   102 my $tmpdir = ($ENV{"TMPDIR"} || "/tmp");

   104 #   parse command line options

   105 my $opts = {};

   106 @ARGV = getopts("hvr:", $opts, @ARGV);

   108 #   usage sanity check and usage help

   109 sub usage {

   110     my ($rc) = @_;

   111     my $usage = "openpkg:$prog_name:USAGE: openpkg search <regex>\n";

   112     if ($rc == 0) {

   113         print STDOUT $usage;

   114     }

   115     else {

   116         print STDERR $usage;

   117     }

   118     exit($rc);

   119 }

   120 if ($opts->{"h"}) {

   121     usage(0);

   122 }

   123 if (@ARGV == 0) {

   124     usage(1);

   125 }

   127 #   take command line arguments

   128 my $keyword = $ARGV[0];

   130 #   determine start URL

   131 my $url = $opts->{"r"} || "";

   132 if ($url eq "") {

   133     $url = run("$my_prefix/bin/openpkg release --fmt='%u' 2>/dev/null");

   134     $url =~ s/^\s+//s;

   135     $url =~ s/\s+$//s;

   136 }

   137 if ($url eq "") {

   138     print STDERR "openpkg:$prog_name:ERROR: no repository URL known\n";

   139     exit(1);

   140 }

   142 #   recursively download XML/RDF index

   143 sub relurl ($$) {

   144     my ($url, $suburl) = @_;

   145     if ($suburl =~ m/^\w+:\/\//) {

   146         $url = $suburl;

   147     }

   148     elsif ($suburl =~ m/^\//) {

   149         $url = "file://$suburl";

   150     }

   151     else {

   152         $url =~ s/(\/)?\/*[^\/]*$/$1$suburl/;

   153     }

   154     1 while ($url =~ s/\/\.\//\//s);

   155     1 while ($url =~ s/\/[^\/]+\/\.\.\//\//s);

   156     return $url;

   157 }

   158 sub get_index ($) {

   159     my ($url) = @_;

   160     if ($url =~ m/^\//) {

   161         $url = "file://$url";

   162     }

   163     if ($url =~ m/\/$/) {

   164         $url .= "00INDEX.rdf";

   165     }

   166     my $cmd = "$my_prefix/bin/openpkg curl -s -o- \"$url\" 2>/dev/null";

   167     if ($url =~ m/\.bz2$/) {

   168         $cmd .= " | $my_prefix/lib/openpkg/bzip2 -d -c";

   169     }

   170     my $xml = run($cmd);

   171     my @includes = ();

   172     while ($xml =~ m/<Repository\s+[^>]*href="([^"]*)"/gs) {

   173         push(@includes, $1);

   174     }

   175     foreach my $include (@includes) {

   176         $xml .= get_index(relurl($url, $include));

   177     }

   178     return $xml;

   179 }

   180 my $xml = get_index($url);

   182 #   parse XML/RDF index

   183 my $x = $xml;

   184 $x =~ s/<rdf:Description\s+about="([^"]+)".*?>(.+?)<\/rdf:Description>/do1($1, $2), ''/sge;

   185 sub do1 {

   186     my ($nvr, $xml) = @_;

   187     my ($name) = ($xml =~ m|<Name>(.+?)</Name>|s);

   188     my ($vers) = ($xml =~ m|<Version>(.+?)</Version>|s);

   189     my ($rele) = ($xml =~ m|<Release>(.+?)</Release>|s);

   190     my ($summ) = ($xml =~ m|<Summary>(.+?)</Summary>|s);

   191     my ($desc) = ($xml =~ m|<Description>(.+?)</Description>|s);

   192     if (   $name =~ m|$keyword|si

   193         or $summ =~ m|$keyword|si

   194         or $desc =~ m|$keyword|si) {

   195         do2($nvr, $name, $vers, $rele, $summ, $desc, $xml);

   196     }

   197 }

   198 sub do2 {

   199     my ($nvr, $name, $vers, $rele, $summ, $desc, $xml) = @_;

   200     return if ($name eq "openpkg");

   201     if ($opts->{"v"}) {

   202         #   itemized verbose output

   203         my ($dist)     = ($xml =~ m|<Distribution>(.+?)</Distribution>|s);

   204         my ($class)    = ($xml =~ m|<Class>(.+?)</Class>|s);

   205         my ($group)    = ($xml =~ m|<Group>(.+?)</Group>|s);

   206         my ($license)  = ($xml =~ m|<License>(.+?)</License>|s);

   207         my ($packager) = ($xml =~ m|<Packager>(.+?)</Packager>|s);

   208         my ($url)      = ($xml =~ m|<URL>(.+?)</URL>|s);

   209         my ($vendor)   = ($xml =~ m|<Vendor>(.+?)</Vendor>|s);

   211         print "Name:     $name\n";

   212         print "Version:  $vers\n";

   213         print "Release:  $rele\n";

   214         print "Group:    $group\n";

   215         print "Class:    $class\n";

   216         print "Distrib:  $dist\n";

   217         print "License:  $license\n";

   218         print "Packager: $packager\n";

   219         print "Vendor:   $vendor\n";

   220         print "Summary:  $summ\n";

   221         print "URL:      $url\n";

   223         print "Description:\n";

   224         $desc =~ s/^\s+//mg;

   225         $desc =~ s/\s+$//mg;

   226         $desc =~ s/^/    /mg;

   227         print "$desc\n";

   229         my ($prov) = ($xml =~ m|<Provides>(.+?)</Provides>|s);

   230         if (($prov || "") ne "") {

   231             print "Provides:\n";

   232             $prov =~ s/<resource\s+equ="([^"]*)">(.+?)<\/resource>/do3($1, $2), ''/sge;

   233             sub do3 {

   234                 my ($val, $name) = @_;

   235                 print "    $name = $val\n";

   236             }

   237         }

   239         print "\n";

   240     }

   241     else {

   242         #   tabular brief output

   243         printf("%-20s %-10s %-9s %s\n", $name, $vers, $rele, $summ);

   244     }

   245 }

OpenPKG Specs / file revision

openpkg/search.pl@a2c6460cfb16

openpkg/search.pl