/[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 104 - (hide annotations) (download)
Sun Sep 17 12:53:36 2006 UTC (8 years ago) by yuval
File size: 10485 byte(s)
Slurping the file in subroutine getFileContents (less iterations, thus less OPs); fixed the problem with USE flags being filled with minus signs (had to check if  is empty before pushing to @USEs)
1 ian 96 #!/usr/bin/perl
2    
3     # -----------------------------------------------------------------------------
4     #
5     # perl-info
6     #
7 ian 98 # date : 2006-09-10
8 ian 96 # author : Christian Hartmann <ian@gentoo.org>
9 ian 98 # version : 0.11
10 ian 96 # 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 98 my $VERSION = "0.11";
32 ian 96 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     open(FH,"<".$_[0]) || die("Cannot open file ".$_[0]);
295 yuval 104 my $content = do{local $/; <FH>};
296 ian 96 close(FH);
297     return $content;
298     }
299    
300     # Description:
301 ian 98 # Returnvalue is PORTDIR from make.conf or make.globals (make.conf overrules make.globals).
302     # $portdir = getPortdir();
303 ian 96 sub getPortdir
304     {
305     return getParamFromFile(getFileContents("/etc/make.globals").getFileContents("/etc/make.conf"),"PORTDIR","lastseen");
306     }
307    
308 ian 98 # Description:
309     # Prints a fancy header.
310 ian 96 sub printHeader
311     {
312     print "\n";
313     print $green." perl-info".$reset." version ".$VERSION." - brought to you by the Gentoo perl-herd-maintainer ;-)\n";
314     print " Distributed under the terms of the GPL-2\n";
315     print "\n";
316     }
317    
318     # Description:
319     # Returns useflag settings of the given (installed) package.
320     # @useflags = getUseSettingsOfPackage("dev-perl/perl-5.8.8-r3");
321     sub getUseSettingsOfPackage
322     {
323     my $package = shift;
324     my $packagepath = (searchInstalled($pkgdbdir,$package))[0];
325     my $tmp_filecontents = "";
326     my @package_IUSE = ();
327     my @package_USE = ();
328     my @USEs = ();
329    
330     $tmp_filecontents=getFileContents($pkgdbdir."/".$packagepath."/IUSE");
331     $tmp_filecontents=~s/\n//g;
332     @package_IUSE = split(/ /,$tmp_filecontents);
333     $tmp_filecontents=getFileContents($pkgdbdir."/".$packagepath."/USE");
334     $tmp_filecontents=~s/\n//g;
335     @package_USE = split(/ /,$tmp_filecontents);
336    
337    
338     foreach my $thisIUSE (@package_IUSE)
339     {
340     my $hasuse = "-";
341     foreach my $thisUSE (@package_USE)
342     {
343     if ($thisIUSE eq $thisUSE)
344     {
345     $hasuse="";
346     last;
347     }
348     }
349 yuval 104 push(@USEs,$hasuse.$thisIUSE) unless ($thisIUSE eq "");
350 ian 96 }
351    
352     return @USEs;
353     }
354    
355     # - Here comes the POD >
356    
357     =head1 NAME
358    
359     perl-info - gather systems perl info
360    
361     =head1 VERSION
362    
363 ian 98 This document refers to version 0.11 of perl-info
364 ian 96
365     =head1 SYNOPSIS
366    
367     perl-info
368    
369     =head1 DESCRIPTION
370    
371     perl-info shall help developers getting sufficient information about the
372     users perl installation when needed.
373    
374     =head1 AGRUMENTS
375    
376     perl-info does not have any arguments yet.
377    
378     =head1 AUTHOR
379    
380     Christian Hartmann <ian@gentoo.org>
381    
382     =head1 TODO
383    
384     Put your stuff here and poke me.
385    
386     =head1 REPORTING BUGS
387    
388     Please report bugs via http://bugs.gentoo.org/ or https://bugs.gentoo.org/
389    
390     =head1 LICENSE
391    
392     perl-info - gather systems perl info
393     Copyright (C) 2006 Christian Hartmann
394    
395     This program is free software; you can redistribute it and/or modify
396     it under the terms of the GNU General Public License as published by
397     the Free Software Foundation; either version 2 of the License, or
398     (at your option) any later version.
399    
400     This program is distributed in the hope that it will be useful,
401     but WITHOUT ANY WARRANTY; without even the implied warranty of
402     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
403     GNU General Public License for more details.
404    
405     You should have received a copy of the GNU General Public License
406     along with this program; if not, write to the Free Software
407     Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA
408    
409     =cut

Properties

Name Value
svn:executable *

  ViewVC Help
Powered by ViewVC 1.1.20