/[gentoo-src]/ufed/Portage.pm
Gentoo

Contents of /ufed/Portage.pm

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.7 - (show annotations) (download) (as text)
Wed Apr 26 09:29:54 2006 UTC (8 years, 5 months ago) by truedfx
Branch: MAIN
CVS Tags: HEAD
Changes since 1.6: +58 -41 lines
File MIME type: text/x-perl
source support, and don't too much during BEGIN

1 package Portage;
2 use strict;
3 use warnings;
4
5 # Copyright 1999-2005 Gentoo Foundation
6 # Distributed under the terms of the GNU General Public License v2
7 # $Header: /var/cvsroot/gentoo-src/ufed/Portage.pm,v 1.6 2006/04/25 12:51:07 truedfx Exp $
8
9 our %environment;
10 our %packages;
11 our @profiles;
12 our @use_expand;
13 our %use_masked_flags;
14 our %use_defaults_flags;
15 our %make_defaults_flags;
16 our %default_flags;
17 our %make_conf_flags;
18 our %archs;
19 our %all_flags;
20 our @portagedirs;
21
22 sub have_package($);
23 sub merge(\%%);
24 sub merge_env(\%);
25 sub noncomments($);
26 sub norm_path($$);
27 sub read_archs();
28 sub read_make_conf();
29 sub read_make_defaults();
30 sub read_make_globals();
31 sub read_packages();
32 sub read_profiles();
33 sub read_sh($);
34 sub read_use_defaults();
35 sub read_use_mask();
36
37 INIT {
38 $environment{$_}={} for qw(USE USE_EXPAND); # INCREMENTALS, except only what we need
39
40 read_profiles;
41 read_use_mask;
42 read_use_defaults;
43 read_make_globals;
44 read_make_defaults;
45 read_make_conf;
46 read_archs;
47
48 my $lastorder;
49 for(reverse split /:/, $environment{USE_ORDER} || "env:pkg:conf:auto:defaults") {
50 if($_ eq 'defaults') {
51 merge %default_flags, %make_defaults_flags;
52 merge %all_flags, %make_defaults_flags;
53 } elsif($_ eq 'auto') {
54 read_packages if not %packages;
55 merge %default_flags, %use_defaults_flags;
56 merge %all_flags, %use_defaults_flags;
57 } elsif($_ eq 'conf') {
58 merge %all_flags, %make_conf_flags;
59 } else {
60 next;
61 }
62 $lastorder = $_;
63 }
64 if($lastorder ne 'conf') {
65 die "Sorry, USE_ORDER without make.conf overriding global USE flags are not currently supported by ufed.\n";
66 }
67
68 # Hardcoded magic is bad, suggestions for a way to determine
69 # these automatically and reliably would be appreciated.
70 delete @{$environment{USE_EXPAND}}{qw/ELIBC KERNEL USERLAND/};
71
72 @use_expand = keys %{$environment{USE_EXPAND}};
73 for my $expvar(@use_expand) {
74 $all_flags{(lc $expvar)."_".$_} = 1 for split ' ', $environment{$expvar} || '';
75 }
76 @use_expand = sort map lc, @use_expand;
77 }
78
79 for(keys %use_masked_flags)
80 { delete $all_flags{$_} if $use_masked_flags{$_} and exists $all_flags{$_} }
81
82 sub have_package($) {
83 my ($cp) = @_;
84 return $packages{$cp};
85 }
86
87 sub merge(\%%) {
88 my ($env, %env) = @_;
89 %{$env} = () if(exists $env{'*'});
90 $env->{$_} = $env{$_} for(keys %env);
91 }
92
93 sub merge_env(\%) {
94 my ($env) = @_;
95 for(keys %environment) {
96 if(ref $environment{$_} eq 'HASH') {
97 if(exists $env->{$_}) {
98 my %split;
99 for(split ' ', $env->{$_}) {
100 my $off = s/^-//;
101 %split = () if($_ eq '*');
102 $split{$_} = !$off;
103 }
104 $env->{$_} = { %split };
105 merge %{$environment{$_}}, %{$env->{$_}};
106 }
107 }
108 }
109 for(keys %{$env}) {
110 if(ref $environment{$_} ne 'HASH') {
111 $environment{$_} = $env->{$_};
112 }
113 }
114 }
115
116 sub noncomments($) {
117 my ($fname) = @_;
118 my @result;
119 local $/;
120 if(open my $file, '<', $fname) {
121 @result = split /(?:[^\S\n]*(?:#.*)?\n)+/, <$file>."\n";
122 shift @result if @result>0 && $result[0] eq '';
123 close $file;
124 }
125 return @result;
126 }
127
128 sub norm_path($$) {
129 my ($base, $path) = @_;
130 my @pathcomp = ($path !~ m!^/! && split(m!/!, $base), split(m!/!, $path));
131 for(my $i=0;;$i++) {
132 last if $i == @pathcomp; # don't want to skip this with redo
133 if($pathcomp[$i] eq '' || $pathcomp[$i] eq '.') {
134 splice @pathcomp, $i, 1;
135 redo;
136 }
137 if($pathcomp[$i] eq '..') {
138 if($i==0) {
139 splice @pathcomp, 0, 1;
140 } else {
141 splice @pathcomp, --$i, 2;
142 }
143 redo;
144 }
145 }
146 return '/'.join '/', @pathcomp;
147 }
148
149 sub read_archs() {
150 for my $dir(@portagedirs) {
151 for(noncomments "$dir/profiles/arch.list") {
152 $archs{$_} = 1;
153 }
154 }
155 }
156
157 sub read_make_conf() {
158 my %env = read_sh "/etc/make.conf";
159 merge %make_conf_flags, %{$env{USE}} if exists $env{USE};
160 @portagedirs = $environment{PORTDIR};
161 push @portagedirs, split ' ', $environment{PORTDIR_OVERLAY} if defined $environment{PORTDIR_OVERLAY};
162 }
163
164 sub read_make_defaults() {
165 for my $dir(@profiles) {
166 my %env = read_sh "$dir/make.defaults";
167 merge %make_defaults_flags, %{$env{USE}} if exists $env{USE};
168 }
169 }
170
171 sub read_make_globals() {
172 for my $dir(@profiles, '/etc') {
173 read_sh "$dir/make.globals";
174 }
175 }
176
177 sub read_packages() {
178 die "Couldn't read /var/db/pkg\n" unless opendir my $pkgdir, '/var/db/pkg';
179 while(my $cat = readdir $pkgdir) {
180 next if $cat eq '.' or $cat eq '..';
181 next unless opendir my $catdir, "/var/db/pkg/$cat";
182 while(my $pkg = readdir $catdir) {
183 next if $pkg eq '.' or $pkg eq '..';
184 if(open my $provide, '<', "/var/db/pkg/$cat/$pkg/PROVIDE") {
185 if(open my $use, '<', "/var/db/pkg/$cat/$pkg/USE") {
186 # could be shortened, but make sure not to strip off part of the name
187 $pkg =~ s/-\d+(?:\.\d+)*\w?(?:_(?:alpha|beta|pre|rc|p)\d*)?(?:-r\d+)?$//;
188 $packages{"$cat/$pkg"} = 1;
189 local $/;
190 my @provide = split ' ', <$provide>;
191 my @use = split ' ', <$use>;
192 for(my $i=0; $i<@provide; $i++) {
193 my $pkg = $provide[$i];
194 next if $pkg eq '(' || $pkg eq ')';
195 if($pkg !~ s/\?$//) {
196 $pkg =~ s/-\d+(?:\.\d+)*\w?(?:_(?:alpha|beta|pre|rc|p)\d*)?(?:-r\d+)?$//;
197 $packages{$pkg} = 1;
198 } else {
199 my $musthave = $pkg !~ s/^!//;
200 my $have = 0;
201 for(@use) {
202 if($pkg eq $_)
203 { $have = 1; last }
204 }
205 if($musthave != $have) {
206 my $level = 0;
207 for($i++;$i<@provide;$i++) {
208 $level++ if $provide[$i] eq '(';
209 $level-- if $provide[$i] eq ')';
210 last if $level==0;
211 }
212 }
213 }
214 }
215 close $use;
216 }
217 close $provide;
218 }
219 }
220 closedir $catdir;
221 }
222 closedir $pkgdir;
223 }
224
225 sub read_profiles() {
226 $_ = readlink '/etc/make.profile';
227 die "/etc/make.profile is not a symlink\n" if not defined $_;
228 @profiles = norm_path '/etc', $_;
229 PARENT: {
230 for(noncomments "$profiles[0]/parent") {
231 unshift @profiles, norm_path $profiles[0], $_;
232 redo PARENT;
233 }
234 }
235 }
236
237 sub read_sh($) {
238 my $BLANK = qr{(?:[ \n\t]+|#.*)+}; # whitespace and comments
239 my $IDENT = qr{([^ \\\n\t'"{}=]+)}; # identifiers
240 my $ASSIG = qr{=}; # assignment operator
241 my $UQVAL = qr{((?:[^ \\\n\t'"]+|\\.)+)}s; # unquoted value
242 my $SQVAL = qr{'([^']*)'}; # singlequoted value
243 my $DQVAL = qr{"((?:[^\\"]|\\.)*)"}s; # doublequoted value
244
245 my ($fname) = @_;
246 my %env;
247 if(open my $file, '<', $fname) {
248 { local $/; $_ = <$file> }
249 eval {
250 for(;;) {
251 /\G$BLANK/gc;
252 last if (pos || 0) == length;
253 /\G$IDENT/gc or die;
254 my $name = $1;
255 /\G$BLANK/gc;
256 if($name ne 'source') {
257 /\G$ASSIG/gc or die;
258 /\G$BLANK/gc;
259 }
260 die if pos == length;
261 my $value = '';
262 for(;;) {
263 if(/\G$UQVAL/gc || /\G$DQVAL/gc) {
264 my $addvalue = $1;
265 $addvalue =~ s[
266 \\\n | # backslash-newline
267 \\(.) | # other escaped characters
268 \$({)? # $
269 $IDENT # followed by an identifier
270 (?(2)}) # optionally enclosed in braces
271 ][
272 defined $3 ? $env{$3} || '' : # replace envvars
273 defined $1 ? $1 : # unescape escaped characters
274 '' # delete backslash-newlines
275 ]gex;
276 $value .= $addvalue
277 } elsif(/\G$SQVAL/gc) {
278 $value .= $1
279 } else {
280 last
281 }
282 }
283 if($name eq 'source') {
284 open my $f, '<', $value or die;
285 my $pos = pos;
286 substr($_, pos, 0) = do {
287 local $/;
288 my $text = <$f>;
289 die if not defined $text;
290 $text;
291 };
292 pos = $pos;
293 close $f or die;
294 } else {
295 $env{$name} = $value;
296 }
297 }
298 };
299 die "Parse error in $fname\n" if $@;
300 close $file;
301 }
302 merge_env %env;
303 return %env if wantarray;
304 }
305
306 sub read_use_defaults() {
307 for my $dir(@profiles) {
308 for(noncomments "$dir/use.defaults") {
309 my ($flag, @packages) = split;
310 for(@packages)
311 { $use_defaults_flags{$flag} = 1 if have_package $_ }
312 }
313 }
314 }
315
316 sub read_use_mask() {
317 for my $dir(@profiles) {
318 for(noncomments "$dir/use.mask") {
319 my $off = s/^-//;
320 $use_masked_flags{$_} = !$off;
321 }
322 }
323 }
324
325 1;

  ViewVC Help
Powered by ViewVC 1.1.20