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