Commit | Line | Data |
---|---|---|
135a59c2 | 1 | # -*- Mode: cperl; coding: utf-8; cperl-indent-level: 4 -*- |
135a59c2 | 2 | use strict; |
547d3dfd SP |
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 A |
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 A |
68 | |
69 | use vars qw{ @All $VERSION }; | |
547d3dfd SP |
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 SP |
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 A |
87 | } |
88 | ||
89 | # CPAN::Queue::first ; | |
90 | sub first { | |
547d3dfd SP |
91 | my $obj = $All[0]; |
92 | $obj; | |
135a59c2 A |
93 | } |
94 | ||
95 | # CPAN::Queue::delete_first ; | |
96 | sub delete_first { | |
547d3dfd SP |
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 A |
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 SP |
112 | join("", |
113 | map {sprintf " %s\[%s]\n",$_->{qmod},$_->{reqtype}} @All, @what | |
114 | ))) if $CPAN::DEBUG; | |
115 | unless (defined $what[0]{reqtype}) { | |
6a935156 SP |
116 | # apparently it was not the Shell that sent us this enquiry, |
117 | # treat it as commandline | |
547d3dfd SP |
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 A |
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 SP |
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 SP |
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 SP |
144 | $CPAN::Frontend->mysleep($sleep); |
145 | # next WHAT; | |
135a59c2 A |
146 | } |
147 | } | |
148 | } | |
547d3dfd SP |
149 | my $obj = "$class\::Item"->new( |
150 | qmod => $what, | |
151 | reqtype => $reqtype | |
152 | ); | |
135a59c2 A |
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 SP |
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 A |
167 | } |
168 | ||
169 | # CPAN::Queue::delete ; | |
170 | sub delete { | |
547d3dfd SP |
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 A |
177 | } |
178 | ||
179 | # CPAN::Queue::nullify_queue ; | |
180 | sub nullify_queue { | |
547d3dfd | 181 | @All = (); |
135a59c2 A |
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 |