Andrew Gaffney <[EMAIL PROTECTED]> wrote:
: : I think that 'my' is bad because I have something similar to:
: : my %tree;
: : sub return_an_arrayref() {
: my @array = ('thing1', 'thing2', 'thing3');
: return [EMAIL PROTECTED];
: }
: : sub build_tree() {
: foreach(@thing) {
: $tree{$_} = return_an_arrayref();
: }
: }
: : use Data::Dumper;
: print Dumper(%tree);
: : The output shows a bunch of empty arrays or arrays with
: all undef elements under each key in %tree. I know
: return_an_arrayref() is returning data because I can
: print all the elements out in build_tree().
Remember Finagle's Third Law:
"In any collection of data, the figure most obviously correct, beyond all need of checking, is the mistake."
Your results indicate that return_an_arrayref() does sometimes return a reference to an empty array. Show us unedited code for more help.
Alright, you asked for it. In order to run this program, you will need to be running Gentoo Linux as this program uses the Portage tree and Portage's config files.
#!/usr/bin/perl
use strict; #use warnings;
#use Getopt::Long;
my %masks; my %use; my @pkglist; my %pkgdeps;
sub get_masks {
my @maskfiles = ("/usr/portage/profiles/package.mask", "/etc/portage/package.mask");
foreach my $maskfile (@maskfiles) {
open MASKS, "< $maskfile" or next;
while(<MASKS>) {
chomp;
next if($_ eq '' || /^#/);
my $list = expand_package_list($_, 1);
foreach my $pkg (@$list) {
$masks{$pkg} = 1;
}
}
close MASKS;
}
}sub get_unmasks {
my @maskfiles = ("/etc/portage/package.unmask"); foreach my $maskfile (@maskfiles) {
open UNMASKS, "< $maskfile" or next;
while(<UNMASKS>) {
chomp;
next if($_ eq '' || /^#/);
my $list = expand_package_list($_, 1);
foreach my $pkg (@$list) {
delete $masks{$pkg} if(exists $masks{$pkg});
}
}
close UNMASKS;
}}
sub process_use_flags {
my $useflags = shift; $useflags =~ s/(\\|\n)/ /sg;
$useflags =~ s/\s+/ /g;
my @useflags = split /\s+/, $useflags;
foreach(@useflags) {
if($_ eq '-*') {
foreach(keys %use) {
delete $use{$_};
}
} elsif(/^-(.+)$/) {
delete $use{$1} if(exists $use{$1});
} else {
$use{$_} = 1;
}
}
}sub get_make_config {
my @makeconfs = ("/etc/make.profile/make.defaults", "/etc/make.conf");
my $makecontents; foreach my $makeconf (@makeconfs) {
open MAKECONF, "< $makeconf" or next;
while(<MAKECONF>) {
$makecontents .= $_;
}
close MAKECONF;
$makecontents =~ /\s+USE=\"(.+?)\"{1}?/s;
my $useflags = $1;
process_use_flags($useflags);
}
}sub get_env_config {
my $useflags = $ENV{USE};
process_use_flags($useflags) if($useflags ne '');
}sub enable_autouse {
open USE, "< /etc/make.profile/use.defaults" or die "Can't open use.defaults\n";
foreach(<USE>) {
next if(/^(#.+)?$/);
/^(.+)\s+(.+)$/;
foreach(split /\s+/, $2) {
my ($useflag, $pkgname) = ($1, $2);
process_use_flags($useflag) if(check_package_installed($pkgname));
}
}
}sub init {
get_masks();
get_unmasks();
get_make_config();
get_env_config();
enable_autouse();
print join(', ', sort keys %use) . "\n";
}sub get_depend {
my $ebuildfname = shift;
my $ebuildcontents;
my %ebuildvars;
my $pkgname = $ebuildfname; $pkgname =~ s|/usr/portage/||;
$pkgname =~ s|(.+)/.+/(.+).ebuild|$1/$2|;
my $pkg = parse_package_name($pkgname);
$pkg->{version} =~ s/^-//;
$ebuildvars{PV} = "$pkg->{version}";open EBUILD, "< $ebuildfname" or die "Couldn't open '$ebuildfname' to get DEPEND\n";
while(<EBUILD>) {
$ebuildcontents .= $_;
}
close EBUILD;
while($ebuildcontents =~ /\b([-A-Z0-9_]+)=\"(.*?)\"{1}?/sgc) {
$ebuildvars{$1} = $2;
}
foreach(keys %ebuildvars) {
$ebuildvars{$_} =~ s/\$\{?([-A-Z0-9_]+)\}?/$ebuildvars{$1}/gs;
}
my $depend = $ebuildvars{'DEPEND'};
$depend =~ s/(\s+|\n+)/ /gs;return $depend; }
sub check_package_installed {
my $pkgname = shift;
my $pkg = parse_package_name($pkgname);if($pkg->{version} eq '') {
opendir PKGDIR, "/var/db/pkg/$pkg->{category}" or die "Can't open directory '/var/db/pkg/$pkg->{category}'\n";
my @pkgs = grep { /^$pkg->{name}-/ } readdir(PKGDIR);
close PKGDIR;
push @pkgs, '';
return 1 if($#pkgs);
} else {
my $pkgdir = "/var/db/pkg/$pkg->{category}/$pkg->{name}$pkg->{version}$pkg->{suffix}$pkg->{revision}";
return 1 if(-d $pkgdir);
}
return 0; }
sub expand_depend {
my $depstring = shift;
my @deplist;
my $paren = 0;
my @skipuseflag = (0, 0, 0, 0, 0, 0, 0, 0, 0, 0);$depstring =~ s/\s*\(\s*/ ( /g; $depstring =~ s/\s*\)\s*/ ) /g;
my @depparts = split /\s+/, $depstring;
for my $lv (0..$#depparts) {
# print "$lv - $depparts[$lv] - skipuseflag[$paren] = $skipuseflag[$paren]\n";
if($depparts[$lv] eq '(') {
$paren++;
# print "Found '(', skipuseflag[$paren] = $skipuseflag[$paren], paren = $paren\n";
next;
}
if($depparts[$lv] eq ')') {
$skipuseflag[$paren] = 0;
$paren--;
# print "Found ')', skipuseflag[$paren] = $skipuseflag[$paren], paren = $paren\n";
next;
}
next if($skipuseflag[$paren] && $depparts[$lv] !~ /\?$/);
if($depparts[$lv] =~ /^(!)?(.+)\?$/) {
# print "Found USE flag $2\n";
if($skipuseflag[$paren]) {
# print "Setting skipuseflag[${paren}+1] to 1\n";
$skipuseflag[$paren+1] = 1;
next;
}
# print "Processing USE flag $2\n";
if($1 eq '!') {
if(exists $use{$2}) {
$skipuseflag[$paren+1] = 1;
}
} else {
if(!exists $use{$2}) {
$skipuseflag[$paren+1] = 1;
}
}
} else {
push @deplist, $depparts[$lv] unless($depparts[$lv] =~ /^(!|virtual)/ || $depparts[$lv] =~ /\*$/);
# print "Adding dependency '$depparts[$lv]' at level $paren\n";
}
}
return [EMAIL PROTECTED]; }
sub parse_package_name {
my $pkgname = shift;
my $pkgregex =
'^(<=|>=|=>|=<|<|>|=)?'. # equal, gt, lt, etc.
'((.+-.+)\/)?'. # category
'(.+?)'. # name
'(-(\d+(?:\.\d+)*[a-z]*))?'. # version, eg 1.23.4a
'((?:(?:_alpha|_beta|_pre|_rc|_[a-zA-Z]+\d+)\d*)?)'. # special suffix
'((?:-r\d+)?)(\.ebuild)?$'; # revision, eg r12$pkgname =~ /$pkgregex/;
my $package = {gtlteq=>($1||''), category=>$3, name=>$4, version=>($5||''), suffix=>($7||''), revision=>($8||'')};
return $package; }
sub compare_versions {
my @args = @_;
my $betas = {_alpha=>1, _beta=>2, _pre=>3, _rc=>4};my $det1 = {version=>$args[0], suffix=>$args[1], revision=>$args[2]};
$det1->{version} =~ s/^-//;
my @version1 = split /\./, $det1->{version};
my $det2 = {version=>$args[3], suffix=>$args[4], revision=>$args[5]};
$det2->{version} =~ s/^-//;
my @version2 = split /\./, $det2->{version};
return 0 if("$det1->{version}$det1->{suffix}$det1->{revision}" eq "$det2->{version}$det2->{suffix}$det2->{revision}");
# print "1 - '$det1->{version}' '$det1->{suffix}' '$det1->{revision}'\n";
# print "2 - '$det2->{version}' '$det2->{suffix}' '$det2->{revision}'\n"; for my $l (0..$#version1) {
return 1 if($version1[$l] > $version2[$l]);
return 2 if($version1[$l] < $version2[$l]);
}
if($det1->{suffix} ne '' || $det2->{suffix} ne '') {
return 1 if($det1->{suffix} eq '');
return 2 if($det2->{suffix} eq '');
$det1->{suffix} =~ /^_?(.+)(\d+)$/;
my ($suffix11, $suffix12) = ($1, $2);
$det2->{suffix} =~ /^_?(.+)(\d+)$/;
my ($suffix21, $suffix22) = ($1, $2);
return 1 if($suffix21 eq '' && $suffix11 ne '' && !exists $betas->{suffix11});
return 2 if($suffix11 eq '' && $suffix21 ne '' && !exists $betas->{suffix21});
# return 2 if($suffix21 eq '');
if($suffix11 ne $suffix21) {
return 1 if($betas->{$suffix11} > $betas->{$suffix21});
return 2;
} else {
return 1 if($suffix12 > $suffix22);
return 2;
}
}
if($det1->{revision} ne '' || $det2->{revision} ne '') {
return 2 if($det1->{revision} eq '');
return 1 if($det2->{revision} eq '');
$det1->{revision} =~ /^-r(\d+)$/;
my $rev1 = $1;
$det2->{revision} =~ /^-r(\d+)$/;
my $rev2 = $1;
return 1 if($rev1 > $rev2);
return 2;
}return 0; }
sub expand_package_list {
my $entry = shift;
my $ignoremask = shift || 0;
my @list;
my $pkg = parse_package_name($entry);
my $pkgdir = "/usr/portage/$pkg->{category}/$pkg->{name}";opendir PKGDIR, $pkgdir or return;
my @ebuilds = grep { /\.ebuild$/ } readdir(PKGDIR);
closedir PKGDIR;
foreach my $ebuild (@ebuilds) {
$ebuild = "$pkg->{category}/" . $ebuild;
$ebuild =~ s/\.ebuild$//;
my $pkg2 = parse_package_name($ebuild);
my $cmpver = compare_versions($pkg->{version}, $pkg->{suffix}, $pkg->{revision}, $pkg2->{version}, $pkg2->{suffix}, $pkg2->{revision});
# print "Compared versions '$pkg->{version}$pkg->{suffix}$pkg->{revision}' and '$pkg2->{version}$pkg2->{suffix}$pkg2->{revision}' = $cmpver\n";
if($pkg->{gtlteq} eq '=') {
push @list, $ebuild if(($ignoremask || ! exists $masks{$ebuild}) && $cmpver eq 0);
} elsif($pkg->{gtlteq} eq '<') {
push @list, $ebuild if(($ignoremask || ! exists $masks{$ebuild}) && $cmpver eq 1);
} elsif($pkg->{gtlteq} eq '>') {
push @list, $ebuild if(($ignoremask || ! exists $masks{$ebuild}) && $cmpver eq 2);
} elsif($pkg->{gtlteq} eq '<=' || $pkg->{gtlteq} eq '=<') {
push @list, $ebuild if(($ignoremask || ! exists $masks{$ebuild}) && ($cmpver eq 0 || $cmpver eq 1));
} elsif($pkg->{gtlteq} eq '>=' || $pkg->{gtlteq} eq '=>') {
push @list, $ebuild if(($ignoremask || ! exists $masks{$ebuild}) && ($cmpver eq 0 || $cmpver eq 2));
} else {
push @list, $ebuild if($ignoremask || ! exists $masks{$ebuild});
}
}
return [EMAIL PROTECTED]; }
sub get_highest_version {
my $list = shift;
my $highest = '';
my $pkg = '';foreach(@$list) {
if($highest eq '') {
$highest = $_;
next;
}
$pkg = parse_package_name($highest) if($pkg eq '');
my $pkg2 = parse_package_name($_);
if(compare_versions($pkg->{version}, $pkg->{suffix}, $pkg->{revision}, $pkg2->{version}, $pkg2->{suffix}, $pkg2->{revision}) == 2) {
$highest = $_;
$pkg = '';
}
}
return $highest; }
sub build_deptree {
my $pkgname = shift;
my $highest = get_highest_version(expand_package_list($pkgname));
my $pkg = parse_package_name($highest);
my $pkgfname = "/usr/portage/$pkg->{category}/$pkg->{name}/$pkg->{name}$pkg->{version}$pkg->{suffix}$pkg->{revision}.ebuild";
my $deps = expand_depend(get_depend($pkgfname));
print "$pkgfname - " . get_depend($pkgfname) . "\n";
print "$pkgfname - " . join(' ', @{expand_depend(get_depend($pkgfname))}) . "\n";return if(exists $pkgdeps{$highest});
foreach(@$deps) {
build_deptree($_) if($_ ne '');
print "$_\n";
} $pkgdeps{$highest} = $deps;
return $highest;
}sub print_deps {
my $pkgname = shift;
my $level = shift || 0; foreach(@{$pkgdeps{$pkgname}}) {
print "Calling print_deps() with '$_'\n";
print_deps($_, ($level+1));
} for(0..$level) {
print " ";
}
print "$pkgname\n";
}sub display_help_message {
print <<' EOF';Perl Portage v0.1 Written by Andrew Gaffney
In its current state, this program can only do the following:
* Build a list of USE flags from /etc/make.profile/make.defaults, /etc/make.conf, and $ENV{USE}
* Build a list of masked packages from /etc/make.profile/package.(un)mask and /etc/portage/package.(un)mask
* Build a list of matching ebuild versions from a '>category/package-version' type string taking masked
packages into account
* Extract the DEPEND line from a particular ebuild
* Parse a DEPEND line using active USE flags and build a list of needed packages
Disclaimer: This program is not guaranteed to do anything except cause the developer to pull out his hair (and
it does that quite well). Use extreme caution when using this tool as it can mess up Portage's
package database, world file, etc. Please backup your /var/db, /var/cache/edb, and /usr/portage
before using. If your system breaks because of this program, please keep in mind that I told you so.
Having said all that, please test this program using your actual Portage database and configuration files. Report
all successes and failures to me at <[EMAIL PROTECTED]>.
EOF }
init();
my $original = build_deptree($ARGV[0]); use Data::Dumper; print Dumper(%pkgdeps);
-- Andrew Gaffney Network Administrator Skyline Aeronautics, LLC. 636-357-1548
-- To unsubscribe, e-mail: [EMAIL PROTECTED] For additional commands, e-mail: [EMAIL PROTECTED] <http://learn.perl.org/> <http://learn.perl.org/first-response>
