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

Properties

Name Value
svn:executable *

  ViewVC Help
Powered by ViewVC 1.1.20