Commit | Line | Data |
---|---|---|
135a59c2 A |
1 | # -*- Mode: cperl; coding: utf-8; cperl-indent-level: 4 -*- |
2 | package CPAN::Queue; | |
3 | use strict; | |
4 | ||
5 | # One use of the queue is to determine if we should or shouldn't | |
6 | # announce the availability of a new CPAN module | |
7 | ||
8 | # Now we try to use it for dependency tracking. For that to happen | |
9 | # we need to draw a dependency tree and do the leaves first. This can | |
10 | # easily be reached by running CPAN.pm recursively, but we don't want | |
11 | # to waste memory and run into deep recursion. So what we can do is | |
12 | # this: | |
13 | ||
14 | # CPAN::Queue is the package where the queue is maintained. Dependencies | |
15 | # often have high priority and must be brought to the head of the queue, | |
16 | # possibly by jumping the queue if they are already there. My first code | |
17 | # attempt tried to be extremely correct. Whenever a module needed | |
18 | # immediate treatment, I either unshifted it to the front of the queue, | |
19 | # or, if it was already in the queue, I spliced and let it bypass the | |
20 | # others. This became a too correct model that made it impossible to put | |
21 | # an item more than once into the queue. Why would you need that? Well, | |
22 | # you need temporary duplicates as the manager of the queue is a loop | |
23 | # that | |
24 | # | |
25 | # (1) looks at the first item in the queue without shifting it off | |
26 | # | |
27 | # (2) cares for the item | |
28 | # | |
29 | # (3) removes the item from the queue, *even if its agenda failed and | |
30 | # even if the item isn't the first in the queue anymore* (that way | |
31 | # protecting against never ending queues) | |
32 | # | |
33 | # So if an item has prerequisites, the installation fails now, but we | |
34 | # want to retry later. That's easy if we have it twice in the queue. | |
35 | # | |
36 | # I also expect insane dependency situations where an item gets more | |
37 | # than two lives in the queue. Simplest example is triggered by 'install | |
38 | # Foo Foo Foo'. People make this kind of mistakes and I don't want to | |
39 | # get in the way. I wanted the queue manager to be a dumb servant, not | |
40 | # one that knows everything. | |
41 | # | |
42 | # Who would I tell in this model that the user wants to be asked before | |
43 | # processing? I can't attach that information to the module object, | |
44 | # because not modules are installed but distributions. So I'd have to | |
45 | # tell the distribution object that it should ask the user before | |
46 | # processing. Where would the question be triggered then? Most probably | |
47 | # in CPAN::Distribution::rematein. | |
48 | # Hope that makes sense, my head is a bit off:-) -- AK | |
49 | ||
50 | use vars qw{ @All $VERSION }; | |
23a216b4 | 51 | $VERSION = sprintf "%.6f", substr(q$Rev: 1704 $,4)/1000000 + 5.4; |
135a59c2 A |
52 | |
53 | # CPAN::Queue::new ; | |
54 | sub new { | |
55 | my($class,@attr) = @_; | |
56 | my $self = bless { @attr }, $class; | |
57 | push @All, $self; | |
58 | CPAN->debug(sprintf("in new All[%s]", | |
59 | join("",map {sprintf " %s\[%s]\n",$_->{qmod},$_->{reqtype}} @All), | |
60 | )) if $CPAN::DEBUG; | |
61 | return $self; | |
62 | } | |
63 | ||
64 | # CPAN::Queue::first ; | |
65 | sub first { | |
66 | my $obj = $All[0]; | |
67 | $obj; | |
68 | } | |
69 | ||
70 | sub as_string { | |
71 | my($self) = @_; | |
72 | $self->{qmod}; | |
73 | } | |
74 | ||
75 | # r => requires, b => build_requires, c => commandline | |
76 | sub reqtype { | |
77 | my($self) = @_; | |
78 | $self->{reqtype}; | |
79 | } | |
80 | ||
81 | # CPAN::Queue::delete_first ; | |
82 | sub delete_first { | |
83 | my($class,$what) = @_; | |
84 | my $i; | |
85 | for my $i (0..$#All) { | |
86 | if ( $All[$i]->{qmod} eq $what ) { | |
87 | splice @All, $i, 1; | |
88 | return; | |
89 | } | |
90 | } | |
91 | } | |
92 | ||
93 | # CPAN::Queue::jumpqueue ; | |
94 | sub jumpqueue { | |
95 | my $class = shift; | |
96 | my @what = @_; | |
97 | CPAN->debug(sprintf("before jumpqueue All[%s] what[%s]", | |
98 | join("",map {sprintf " %s\[%s]\n",$_->{qmod},$_->{reqtype}} @All), | |
99 | join("",map {sprintf " %s\[%s]",$_->[0],$_->[1]} @what) | |
100 | )) if $CPAN::DEBUG; | |
6a935156 SP |
101 | unless (defined $what[0][1]) { |
102 | # apparently it was not the Shell that sent us this enquiry, | |
103 | # treat it as commandline | |
104 | $what[0][1] = "c"; | |
105 | } | |
135a59c2 A |
106 | my $inherit_reqtype = $what[0][1] =~ /^(c|r)$/ ? "r" : "b"; |
107 | WHAT: for my $what_tuple (@what) { | |
108 | my($what,$reqtype) = @$what_tuple; | |
109 | if ($reqtype eq "r" | |
110 | && | |
111 | $inherit_reqtype eq "b" | |
112 | ) { | |
113 | $reqtype = "b"; | |
114 | } | |
115 | my $jumped = 0; | |
116 | for (my $i=0; $i<$#All;$i++) { #prevent deep recursion | |
117 | # CPAN->debug("i[$i]this[$All[$i]{qmod}]what[$what]") if $CPAN::DEBUG; | |
118 | if ($All[$i]{qmod} eq $what){ | |
119 | $jumped++; | |
f20de9f0 SP |
120 | if ($jumped > 25) { # one's OK if e.g. just processing |
121 | # now; more are OK if user typed | |
122 | # it several times | |
123 | my $sleep = sprintf "%.1f", $jumped/10; | |
135a59c2 | 124 | $CPAN::Frontend->mywarn( |
f20de9f0 | 125 | qq{Warning: Object [$what] queued $jumped times, sleeping $sleep secs!\n} |
135a59c2 | 126 | ); |
f20de9f0 SP |
127 | $CPAN::Frontend->mysleep($sleep); |
128 | # next WHAT; | |
135a59c2 A |
129 | } |
130 | } | |
131 | } | |
132 | my $obj = bless { | |
133 | qmod => $what, | |
134 | reqtype => $reqtype | |
135 | }, $class; | |
136 | unshift @All, $obj; | |
137 | } | |
138 | CPAN->debug(sprintf("after jumpqueue All[%s]", | |
139 | join("",map {sprintf " %s\[%s]\n",$_->{qmod},$_->{reqtype}} @All) | |
140 | )) if $CPAN::DEBUG; | |
141 | } | |
142 | ||
143 | # CPAN::Queue::exists ; | |
144 | sub exists { | |
145 | my($self,$what) = @_; | |
146 | my @all = map { $_->{qmod} } @All; | |
147 | my $exists = grep { $_->{qmod} eq $what } @All; | |
148 | # warn "in exists what[$what] all[@all] exists[$exists]"; | |
149 | $exists; | |
150 | } | |
151 | ||
152 | # CPAN::Queue::delete ; | |
153 | sub delete { | |
154 | my($self,$mod) = @_; | |
155 | @All = grep { $_->{qmod} ne $mod } @All; | |
23a216b4 SP |
156 | CPAN->debug(sprintf("after delete mod[%s] All[%s]", |
157 | $mod, | |
158 | join("",map {sprintf " %s\[%s]\n",$_->{qmod},$_->{reqtype}} @All) | |
159 | )) if $CPAN::DEBUG; | |
135a59c2 A |
160 | } |
161 | ||
162 | # CPAN::Queue::nullify_queue ; | |
163 | sub nullify_queue { | |
164 | @All = (); | |
165 | } | |
166 | ||
167 | 1; | |
168 | ||
169 | __END__ | |
170 | ||
171 | =head1 LICENSE | |
172 | ||
173 | This program is free software; you can redistribute it and/or | |
174 | modify it under the same terms as Perl itself. | |
175 | ||
176 | =cut |