/[gentoo-perl]/perl-info/trunk/bin/perl-info
Gentoo

Contents of /perl-info/trunk/bin/perl-info

Parent Directory Parent Directory | Revision Log Revision Log


Revision 97 - (hide annotations) (download)
Sun Sep 3 07:26:30 2006 UTC (8 years, 3 months ago) by ian
File size: 11138 byte(s)
added perl-gcpan to categories
1 ian 96 #!/usr/bin/perl
2    
3     # -----------------------------------------------------------------------------
4     #
5     # perl-info
6     #
7     # date : 2006-09-02
8     # author : Christian Hartmann <ian@gentoo.org>
9     # version : 0.10
10     # license : GPL-2
11     # description : 'emerge --info' for perl
12     #
13     # header : $Header: $
14     #
15     # -----------------------------------------------------------------------------
16     #
17     # This program is free software; you can redistribute it and/or modify it under
18     # the terms of the GNU General Public License as published by the Free Software
19     # Foundation; either version 2 of the License, or (at your option) any later
20     # version.
21     #
22     # -----------------------------------------------------------------------------
23    
24     # - modules >
25     use warnings;
26     use strict;
27     use DirHandle;
28     use Term::ANSIColor;
29    
30 ian 97 # - init vars & constants >
31 ian 96 my $VERSION = "0.10";
32     my $portdir = getPortdir();
33 ian 97 my @scan_portage_categories = ("dev-perl","perl-core","perl-gcpan");
34 ian 96 my $pkgdbdir = "/var/db/pkg/";
35     my %excludeDirs = ("." => 1, ".." => 1, "metadata" => 1, "licenses" => 1, "eclass" => 1, "distfiles" => 1, "virtual" => 1, "profiles" => 1 , "CVS" => 1);
36    
37     # - init colors >
38     my $yellow = color("yellow bold");
39     my $green = color("bold green");
40     my $white = color("bold white");
41     my $cyan = color("bold cyan");
42     my $red = color("bold red");
43     my $reset = color("reset");
44    
45     # - Print header >
46     printHeader();
47    
48     # - Do some basic checks >
49     if (!-d $portdir)
50     {
51     print $red." *".$reset." PORTDIR not set or incorrect! Aborting..\n";
52     exit(0);
53     }
54    
55     if (!-d $pkgdbdir)
56     {
57     print $red." *".$reset." /var/db/pkg inaccessible? Aborting..\n";
58     exit(0);
59     }
60    
61     # - Start system analysis >
62     print $green." *".$reset." Perl : ".(searchInstalled($pkgdbdir,"dev-lang/perl"))[0]." USE=\"".join(" ",getUseSettingsOfPackage("dev-lang/perl"))."\"\n";
63     print $green." *".$reset." libperl: ".(searchInstalled($pkgdbdir,"sys-devel/libperl"))[0]." USE=\"".join(" ",getUseSettingsOfPackage("sys-devel/libperl"))."\"\n";
64     print "\n";
65    
66     print $green." *".$reset." INC:\n";
67     foreach (@INC)
68     {
69     print " ".$_."\n";
70     }
71     print "\n";
72    
73     foreach my $this_category (@scan_portage_categories)
74     {
75     my $category_str_length = length($this_category)+1;
76     print $green." *".$reset." Installed packages from category ".$this_category.":\n";
77     foreach(searchInstalled($pkgdbdir,$this_category."/*"))
78     {
79     print " ".substr($_,$category_str_length,length($_)-$category_str_length)." USE=\"".join(" ",getUseSettingsOfPackage($_))."\"\n";
80     }
81     print "\n";
82     }
83    
84     print $green." *".$reset." eclasses:\n";
85     foreach my $eclassName ("perl-app","perl-module","perl-post")
86     {
87     my $eclass = getFileContents($portdir."/eclass/".$eclassName.".eclass");
88     $eclass =~ s/\$Header: ([a-zA-Z0-9\/\.,-]+) ([0-9\.]+)/$2/g;
89     print " ".$eclassName.": ".$2."\n";
90     }
91     print "\n";
92     exit(0);
93    
94     # -----------------------------------------------------------------------------
95     # subs >
96     # -----------------------------------------------------------------------------
97    
98     # Description:
99     # Returns an array containing all packages that match $searchString
100     # @packages = searchInstalled($pkgdbdir,$searchString);
101     sub searchInstalled
102     {
103     my $pkgdbdir = shift;
104     my $searchString = shift; if (! $searchString) { $searchString=""; }
105    
106     my $int_c = 0;
107     my $dhc;
108     my $dhp;
109     my $tc;
110     my $tp;
111     my @matches = ();
112    
113     my $s_cat = "";
114     my $s_pak = "";
115     my $m_cat = 0;
116    
117     # - escape special chars >
118     $searchString =~ s/\+/\\\+/g;
119    
120     # - split >
121     if ($searchString=~m/\//)
122     {
123     ($s_cat,$s_pak)=split(/\//,$searchString);
124     }
125     else
126     {
127     $s_pak=$searchString;
128     }
129    
130     $s_cat=~s/\*//g;
131     $s_pak=~s/\*//g;
132    
133     # - read categories >
134     $dhc = new DirHandle($pkgdbdir);
135     if (defined $dhc)
136     {
137     while (defined($tc = $dhc->read))
138     {
139     $m_cat=0;
140     if ($s_cat ne "")
141     {
142     if ($tc=~m/$s_cat/i)
143     {
144     $m_cat=1;
145     }
146     else
147     {
148     next;
149     }
150     }
151    
152     # - not excluded and $_ is a dir?
153     if (! $excludeDirs{$tc} && -d $pkgdbdir."/".$tc)
154     {
155     $dhp = new DirHandle($pkgdbdir."/".$tc);
156     while (defined($tp = $dhp->read))
157     {
158     # - check if packagename matches
159     # (faster if we already check it now) >
160     if ($tp =~m/$s_pak/i || $s_pak eq "")
161     {
162     # - not excluded and $_ is a dir?
163     if (! $excludeDirs{$tp} && -d $pkgdbdir."/".$tc."/".$tp)
164     {
165     if (($s_cat ne "") && ($m_cat))
166     {
167     push(@matches,$tc."/".$tp);
168     }
169     elsif ($s_cat eq "")
170     {
171     push(@matches,$tc."/".$tp);
172     }
173     }
174     }
175    
176     }
177     undef $dhp;
178     }
179     }
180     }
181     undef $dhc;
182    
183     return (sort @matches);
184     }
185    
186     # Description:
187     # Returns the value of $param. Expects filecontents in $file.
188     # $valueOfKey = getParamFromFile($filecontents,$key);
189     # e.g.
190     # $valueOfKey = getParamFromFile(getFileContents("/path/to.ebuild","IUSE","firstseen");
191     sub getParamFromFile
192     {
193     my $file = shift;
194     my $param = shift;
195     my $mode = shift; # ("firstseen","lastseen") - default is "lastseen"
196     my $c = 0;
197     my $d = 0;
198     my @lines = ();
199     my @aTmp = (); # temp (a)rray
200     my $sTmp = ""; # temp (s)calar
201     my $text = ""; # complete text/file after being cleaned up and striped
202     my $value = ""; # value of $param
203     my $this = "";
204    
205     # - 1. split file in lines >
206     @lines = split(/\n/,$file);
207    
208     # - 2 & 3 >
209     for($c=0;$c<=$#lines;$c++)
210     {
211     # - 2. remove leading and trailing whitespaces and tabs from every line >
212     $lines[$c]=~s/^[ |\t]+//; # leading whitespaces and tabs
213     $lines[$c]=~s/[ |\t]+$//; # trailing whitespaces and tabs
214    
215     # - 3. remove comments >
216     $lines[$c]=~s/#(.*)//g;
217    
218     if ($lines[$c]=~/^$param="(.*)"/)
219     {
220     # single-line with quotationmarks >
221     $value=$1;
222    
223     if ($mode eq "firstseen")
224     {
225     # - 6. clean up value >
226     $value=~s/^[ |\t]+//; # remove leading whitespaces and tabs
227     $value=~s/[ |\t]+$//; # remove trailing whitespaces and tabs
228     $value=~s/\t/ /g; # replace tabs with whitespaces
229     $value=~s/ {2,}/ /g; # replace 1+ whitespaces with 1 whitespace
230     return $value;
231     }
232     }
233     elsif ($lines[$c]=~/^$param="(.*)/)
234     {
235     # multi-line with quotationmarks >
236     $value=$1." ";
237     for($d=$c+1;$d<=$#lines;$d++)
238     {
239     # - look for quotationmark >
240     if ($lines[$d]=~/(.*)"/)
241     {
242     # - found quotationmark; append contents and leave loop >
243     $value.=$1;
244     last;
245     }
246     else
247     {
248     # - no quotationmark found; append line contents to $value >
249     $value.=$lines[$d]." ";
250     }
251     }
252    
253     if ($mode eq "firstseen")
254     {
255     # - 6. clean up value >
256     $value=~s/^[ |\t]+//; # remove leading whitespaces and tabs
257     $value=~s/[ |\t]+$//; # remove trailing whitespaces and tabs
258     $value=~s/\t/ /g; # replace tabs with whitespaces
259     $value=~s/ {2,}/ /g; # replace 1+ whitespaces with 1 whitespace
260     return $value;
261     }
262     }
263     elsif ($lines[$c]=~/^$param=(.*)/)
264     {
265     # - single-line without quotationmarks >
266     $value=$1;
267    
268     if ($mode eq "firstseen")
269     {
270     # - 6. clean up value >
271     $value=~s/^[ |\t]+//; # remove leading whitespaces and tabs
272     $value=~s/[ |\t]+$//; # remove trailing whitespaces and tabs
273     $value=~s/\t/ /g; # replace tabs with whitespaces
274     $value=~s/ {2,}/ /g; # replace 1+ whitespaces with 1 whitespace
275     return $value;
276     }
277     }
278     }
279    
280     # - 6. clean up value >
281     $value=~s/^[ |\t]+//; # remove leading whitespaces and tabs
282     $value=~s/[ |\t]+$//; # remove trailing whitespaces and tabs
283     $value=~s/\t/ /g; # replace tabs with whitespaces
284     $value=~s/ {2,}/ /g; # replace 1+ whitespaces with 1 whitespace
285    
286     return $value;
287     }
288    
289     # Description:
290     # Returnvalue is the content of the given file.
291     # $filecontent = getFileContents($file);
292     sub getFileContents
293     {
294     my $content = "";
295    
296     open(FH,"<".$_[0]) || die("Cannot open file ".$_[0]);
297     while(<FH>) { $content.=$_; }
298     close(FH);
299     return $content;
300     }
301    
302     # Description:
303     # @listOfEbuilds = getAvailableEbuilds($PORTDIR, category/packagename);
304     sub getAvailableEbuilds
305     {
306     my $PORTDIR = shift;
307     my $catPackage = shift;
308     my @packagelist = ();
309    
310     if (-e $PORTDIR."/".$catPackage)
311     {
312     # - get list of ebuilds >
313     my $dh = new DirHandle($PORTDIR."/".$catPackage);
314     while (defined($_ = $dh->read))
315     {
316     if ($_ =~ m/(.+)\.ebuild$/)
317     {
318     push(@packagelist,$_);
319     }
320     }
321     }
322    
323     return @packagelist;
324     }
325    
326     # Description:
327     # Returns version of an ebuild. (Without -rX string etc.)
328     # $version = getEbuildVersionSpecial("foo-1.23-r1.ebuild");
329     sub getEbuildVersionSpecial
330     {
331     my $ebuildVersion = shift;
332     $ebuildVersion=substr($ebuildVersion,0,length($ebuildVersion)-7);
333     $ebuildVersion =~ s/^([a-zA-Z0-9\-_\/\+]*)-([0-9\.]+[a-zA-Z]?)([\-r|\-rc|_alpha|_beta|_pre|_p]?)/$2$3/;
334    
335     return $ebuildVersion;
336     }
337    
338     sub getPortdir
339     {
340     return getParamFromFile(getFileContents("/etc/make.globals").getFileContents("/etc/make.conf"),"PORTDIR","lastseen");
341     }
342    
343     sub printHeader
344     {
345     print "\n";
346     print $green." perl-info".$reset." version ".$VERSION." - brought to you by the Gentoo perl-herd-maintainer ;-)\n";
347     print " Distributed under the terms of the GPL-2\n";
348     print "\n";
349     }
350    
351     # Description:
352     # Returns useflag settings of the given (installed) package.
353     # @useflags = getUseSettingsOfPackage("dev-perl/perl-5.8.8-r3");
354     sub getUseSettingsOfPackage
355     {
356     my $package = shift;
357     my $packagepath = (searchInstalled($pkgdbdir,$package))[0];
358     my $tmp_filecontents = "";
359     my @package_IUSE = ();
360     my @package_USE = ();
361     my @USEs = ();
362    
363     $tmp_filecontents=getFileContents($pkgdbdir."/".$packagepath."/IUSE");
364     $tmp_filecontents=~s/\n//g;
365     @package_IUSE = split(/ /,$tmp_filecontents);
366     $tmp_filecontents=getFileContents($pkgdbdir."/".$packagepath."/USE");
367     $tmp_filecontents=~s/\n//g;
368     @package_USE = split(/ /,$tmp_filecontents);
369    
370    
371     foreach my $thisIUSE (@package_IUSE)
372     {
373     my $hasuse = "-";
374     foreach my $thisUSE (@package_USE)
375     {
376     if ($thisIUSE eq $thisUSE)
377     {
378     $hasuse="";
379     last;
380     }
381     }
382     push(@USEs,$hasuse.$thisIUSE);
383     }
384    
385     return @USEs;
386     }
387    
388     # - Here comes the POD >
389    
390     =head1 NAME
391    
392     perl-info - gather systems perl info
393    
394     =head1 VERSION
395    
396     This document refers to version 0.10 of perl-info
397    
398     =head1 SYNOPSIS
399    
400     perl-info
401    
402     =head1 DESCRIPTION
403    
404     perl-info shall help developers getting sufficient information about the
405     users perl installation when needed.
406    
407     =head1 AGRUMENTS
408    
409     perl-info does not have any arguments yet.
410    
411     =head1 AUTHOR
412    
413     Christian Hartmann <ian@gentoo.org>
414    
415     =head1 TODO
416    
417     Put your stuff here and poke me.
418    
419     =head1 REPORTING BUGS
420    
421     Please report bugs via http://bugs.gentoo.org/ or https://bugs.gentoo.org/
422    
423     =head1 LICENSE
424    
425     perl-info - gather systems perl info
426     Copyright (C) 2006 Christian Hartmann
427    
428     This program is free software; you can redistribute it and/or modify
429     it under the terms of the GNU General Public License as published by
430     the Free Software Foundation; either version 2 of the License, or
431     (at your option) any later version.
432    
433     This program is distributed in the hope that it will be useful,
434     but WITHOUT ANY WARRANTY; without even the implied warranty of
435     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
436     GNU General Public License for more details.
437    
438     You should have received a copy of the GNU General Public License
439     along with this program; if not, write to the Free Software
440     Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA
441    
442     =cut

Properties

Name Value
svn:executable *

  ViewVC Help
Powered by ViewVC 1.1.20