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
1 # -*- Mode: cperl; coding: utf-8; cperl-indent-level: 4 -*-
2 use strict;
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;
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.
68
69 use vars qw{ @All $VERSION };
70 $VERSION = "5.5001";
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 }
79
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;
87 }
88
89 # CPAN::Queue::first ;
90 sub first {
91     my $obj = $All[0];
92     $obj;
93 }
94
95 # CPAN::Queue::delete_first ;
96 sub delete_first {
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         }
104     }
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]",
112                         join("",map {sprintf " %s\[%s]\n",$_->{qmod},$_->{reqtype}} @All),
113                         join("",map {sprintf " %s\[%s]\n",$_->{qmod},$_->{reqtype}} @what),
114                        )) if $CPAN::DEBUG;
115     unless (defined $what[0]{reqtype}) {
116         # apparently it was not the Shell that sent us this enquiry,
117         # treat it as commandline
118         $what[0]{reqtype} = "c";
119     }
120     my $inherit_reqtype = $what[0]{reqtype} =~ /^(c|r)$/ ? "r" : "b";
121   WHAT: for my $what_tuple (@what) {
122         my($qmod,$reqtype) = @$what_tuple{qw(qmod reqtype)};
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             if ($All[$i]{qmod} eq $qmod) {
132                 $jumped++;
133             }
134         }
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;
139         my $obj = "$class\::Item"->new(
140                                        qmod => $qmod,
141                                        reqtype => $reqtype
142                                       );
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 ;
151 sub exists {
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;
157 }
158
159 # CPAN::Queue::delete ;
160 sub delete {
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;
167 }
168
169 # CPAN::Queue::nullify_queue ;
170 sub nullify_queue {
171     @All = ();
172 }
173
174 # CPAN::Queue::size ;
175 sub size {
176     return scalar @All;
177 }
178
179 sub 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
200 1;
201
202 __END__
203
204 =head1 LICENSE
205
206 This program is free software; you can redistribute it and/or
207 modify it under the same terms as Perl itself.
208
209 =cut