This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Update CPAN to CPAN version 1.94_62
[perl5.git] / cpan / CPAN / lib / CPAN / Queue.pm
CommitLineData
135a59c2 1# -*- Mode: cperl; coding: utf-8; cperl-indent-level: 4 -*-
135a59c2 2use strict;
547d3dfd
SP
3package CPAN::Queue::Item;
4
5# CPAN::Queue::Item::new ;
6sub new {
7 my($class,@attr) = @_;
8 my $self = bless { @attr }, $class;
9 return $self;
10}
11
12sub as_string {
13 my($self) = @_;
14 $self->{qmod};
15}
16
17# r => requires, b => build_requires, c => commandline
18sub reqtype {
19 my($self) = @_;
20 $self->{reqtype};
21}
22
23package 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
69use vars qw{ @All $VERSION };
0f848f67 70$VERSION = "5.5001";
547d3dfd
SP
71
72# CPAN::Queue::queue_item ;
73sub 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 ;
81sub 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 ;
90sub first {
547d3dfd
SP
91 my $obj = $All[0];
92 $obj;
135a59c2
A
93}
94
95# CPAN::Queue::delete_first ;
96sub 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 ;
108sub jumpqueue {
109 my $class = shift;
110 my @what = @_;
111 CPAN->debug(sprintf("before jumpqueue All[%s] what[%s]",
742adbff
AK
112 join("",map {sprintf " %s\[%s]\n",$_->{qmod},$_->{reqtype}} @All),
113 join("",map {sprintf " %s\[%s]\n",$_->{qmod},$_->{reqtype}} @what),
114 )) if $CPAN::DEBUG;
547d3dfd 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) {
0f848f67 122 my($qmod,$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
0f848f67 131 if ($All[$i]{qmod} eq $qmod) {
135a59c2 132 $jumped++;
135a59c2
A
133 }
134 }
0f848f67
CBW
135 # high jumped values are normal for popular modules when
136 # dealing with large bundles: XML::Simple,
137 # namespace::autoclean, UNIVERSAL::require
138 CPAN->debug("qmod[$qmod]jumped[$jumped]") if $CPAN::DEBUG;
547d3dfd 139 my $obj = "$class\::Item"->new(
0f848f67 140 qmod => $qmod,
547d3dfd
SP
141 reqtype => $reqtype
142 );
135a59c2
A
143 unshift @All, $obj;
144 }
145 CPAN->debug(sprintf("after jumpqueue All[%s]",
146 join("",map {sprintf " %s\[%s]\n",$_->{qmod},$_->{reqtype}} @All)
147 )) if $CPAN::DEBUG;
148}
149
150# CPAN::Queue::exists ;
151sub exists {
547d3dfd
SP
152 my($self,$what) = @_;
153 my @all = map { $_->{qmod} } @All;
154 my $exists = grep { $_->{qmod} eq $what } @All;
155 # warn "in exists what[$what] all[@all] exists[$exists]";
156 $exists;
135a59c2
A
157}
158
159# CPAN::Queue::delete ;
160sub delete {
547d3dfd
SP
161 my($self,$mod) = @_;
162 @All = grep { $_->{qmod} ne $mod } @All;
163 CPAN->debug(sprintf("after delete mod[%s] All[%s]",
164 $mod,
165 join("",map {sprintf " %s\[%s]\n",$_->{qmod},$_->{reqtype}} @All)
166 )) if $CPAN::DEBUG;
135a59c2
A
167}
168
169# CPAN::Queue::nullify_queue ;
170sub nullify_queue {
547d3dfd 171 @All = ();
135a59c2
A
172}
173
5254b38e
SP
174# CPAN::Queue::size ;
175sub size {
176 return scalar @All;
177}
178
07be2ace
CBW
179sub reqtype_of {
180 my($self,$mod) = @_;
181 my $best = "";
182 for my $item (grep { $_->{qmod} eq $mod } @All) {
183 my $c = $item->{reqtype};
184 if ($c eq "c") {
185 $best = $c;
186 last;
187 } elsif ($c eq "r") {
188 $best = $c;
189 } elsif ($c eq "b") {
190 if ($best eq "") {
191 $best = $c;
192 }
193 } else {
194 die "Panic: in reqtype_of: reqtype[$c] seen, should never happen";
195 }
196 }
197 return $best;
198}
199
135a59c2
A
2001;
201
202__END__
203
204=head1 LICENSE
205
206This program is free software; you can redistribute it and/or
207modify it under the same terms as Perl itself.
208
209=cut