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

openpkg/search.pl@d2d0020cfafa (annotated)

openpkg/search.pl

Tue, 28 Aug 2012 18:29:30 +0200

author: Michael Schloh von Bennewitz <michael@schloh.com>
date: Tue, 28 Aug 2012 18:29:30 +0200
changeset 534: d2d0020cfafa
permissions: -rw-r--r--

Update from Drupal 6.x to 7.x and introduce several new HTML5 themes. Because
many themes from Drupal 6.x have since been abandoned, left unmaintained, or
not ported to Drupal 7.x, this package has changed in size and utility.

 ##
 ##  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@d2d0020cfafa (annotated)

openpkg/search.pl