xref: /openbsd-src/gnu/usr.bin/perl/cpan/CPAN/lib/CPAN/Queue.pm (revision 56d68f1e19ff848c889ecfa71d3a06340ff64892) 
1# -*- Mode: cperl; coding: utf-8; cperl-indent-level: 4 -*-
2use strict;
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
23sub optional {
24    my($self) = @_;
25    $self->{optional};
26}
27
28package CPAN::Queue;
29
30# One use of the queue is to determine if we should or shouldn't
31# announce the availability of a new CPAN module
32
33# Now we try to use it for dependency tracking. For that to happen
34# we need to draw a dependency tree and do the leaves first. This can
35# easily be reached by running CPAN.pm recursively, but we don't want
36# to waste memory and run into deep recursion. So what we can do is
37# this:
38
39# CPAN::Queue is the package where the queue is maintained. Dependencies
40# often have high priority and must be brought to the head of the queue,
41# possibly by jumping the queue if they are already there. My first code
42# attempt tried to be extremely correct. Whenever a module needed
43# immediate treatment, I either unshifted it to the front of the queue,
44# or, if it was already in the queue, I spliced and let it bypass the
45# others. This became a too correct model that made it impossible to put
46# an item more than once into the queue. Why would you need that? Well,
47# you need temporary duplicates as the manager of the queue is a loop
48# that
49#
50#  (1) looks at the first item in the queue without shifting it off
51#
52#  (2) cares for the item
53#
54#  (3) removes the item from the queue, *even if its agenda failed and
55#      even if the item isn't the first in the queue anymore* (that way
56#      protecting against never ending queues)
57#
58# So if an item has prerequisites, the installation fails now, but we
59# want to retry later. That's easy if we have it twice in the queue.
60#
61# I also expect insane dependency situations where an item gets more
62# than two lives in the queue. Simplest example is triggered by 'install
63# Foo Foo Foo'. People make this kind of mistakes and I don't want to
64# get in the way. I wanted the queue manager to be a dumb servant, not
65# one that knows everything.
66#
67# Who would I tell in this model that the user wants to be asked before
68# processing? I can't attach that information to the module object,
69# because not modules are installed but distributions. So I'd have to
70# tell the distribution object that it should ask the user before
71# processing. Where would the question be triggered then? Most probably
72# in CPAN::Distribution::rematein.
73
74use vars qw{ @All $VERSION };
75$VERSION = "5.5003";
76
77# CPAN::Queue::queue_item ;
78sub queue_item {
79    my($class,@attr) = @_;
80    my $item = "$class\::Item"->new(@attr);
81    $class->qpush($item);
82    return 1;
83}
84
85# CPAN::Queue::qpush ;
86sub qpush {
87    my($class,$obj) = @_;
88    push @All, $obj;
89    CPAN->debug(sprintf("in new All[%s]",
90                        join("",map {sprintf " %s\[%s][%s]\n",$_->{qmod},$_->{reqtype},$_->{optional}} @All),
91                       )) if $CPAN::DEBUG;
92}
93
94# CPAN::Queue::first ;
95sub first {
96    my $obj = $All[0];
97    $obj;
98}
99
100# CPAN::Queue::delete_first ;
101sub delete_first {
102    my($class,$what) = @_;
103    my $i;
104    for my $i (0..$#All) {
105        if (  $All[$i]->{qmod} eq $what ) {
106            splice @All, $i, 1;
107            last;
108        }
109    }
110    CPAN->debug(sprintf("after delete_first mod[%s] All[%s]",
111                        $what,
112                        join("",map {sprintf " %s\[%s][%s]\n",$_->{qmod},$_->{reqtype},$_->{optional}} @All)
113                       )) if $CPAN::DEBUG;
114}
115
116# CPAN::Queue::jumpqueue ;
117sub jumpqueue {
118    my $class = shift;
119    my @what = @_;
120    CPAN->debug(sprintf("before jumpqueue All[%s] what[%s]",
121                        join("",map {sprintf " %s\[%s][%s]\n",$_->{qmod},$_->{reqtype},$_->{optional}} @All),
122                        join("",map {sprintf " %s\[%s][%s]\n",$_->{qmod},$_->{reqtype},$_->{optional}} @what),
123                       )) if $CPAN::DEBUG;
124    unless (defined $what[0]{reqtype}) {
125        # apparently it was not the Shell that sent us this enquiry,
126        # treat it as commandline
127        $what[0]{reqtype} = "c";
128    }
129    my $inherit_reqtype = $what[0]{reqtype} =~ /^(c|r)$/ ? "r" : "b";
130  WHAT: for my $what_tuple (@what) {
131        my($qmod,$reqtype,$optional) = @$what_tuple{qw(qmod reqtype optional)};
132        if ($reqtype eq "r"
133            &&
134            $inherit_reqtype eq "b"
135           ) {
136            $reqtype = "b";
137        }
138        my $jumped = 0;
139        for (my $i=0; $i<$#All;$i++) { #prevent deep recursion
140            if ($All[$i]{qmod} eq $qmod) {
141                $jumped++;
142            }
143        }
144        # high jumped values are normal for popular modules when
145        # dealing with large bundles: XML::Simple,
146        # namespace::autoclean, UNIVERSAL::require
147        CPAN->debug("qmod[$qmod]jumped[$jumped]") if $CPAN::DEBUG;
148        my $obj = "$class\::Item"->new(
149                                       qmod => $qmod,
150                                       reqtype => $reqtype,
151                                       optional => !! $optional,
152                                      );
153        unshift @All, $obj;
154    }
155    CPAN->debug(sprintf("after jumpqueue All[%s]",
156                        join("",map {sprintf " %s\[%s][%s]\n",$_->{qmod},$_->{reqtype},$_->{optional}} @All)
157                       )) if $CPAN::DEBUG;
158}
159
160# CPAN::Queue::exists ;
161sub exists {
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;
167}
168
169# CPAN::Queue::delete ;
170sub delete {
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][%s]\n",$_->{qmod},$_->{reqtype},$_->{optional}} @All)
176                       )) if $CPAN::DEBUG;
177}
178
179# CPAN::Queue::nullify_queue ;
180sub nullify_queue {
181    @All = ();
182}
183
184# CPAN::Queue::size ;
185sub size {
186    return scalar @All;
187}
188
189sub reqtype_of {
190    my($self,$mod) = @_;
191    my $best = "";
192    for my $item (grep { $_->{qmod} eq $mod } @All) {
193        my $c = $item->{reqtype};
194        if ($c eq "c") {
195            $best = $c;
196            last;
197        } elsif ($c eq "r") {
198            $best = $c;
199        } elsif ($c eq "b") {
200            if ($best eq "") {
201                $best = $c;
202            }
203        } else {
204            die "Panic: in reqtype_of: reqtype[$c] seen, should never happen";
205        }
206    }
207    return $best;
208}
209
210sub iterator {
211    my $i = 0;
212    return sub {
213        until ($All[$i] || $i > $#All) {
214            $i++;
215        }
216        return if $i > $#All;
217        return $All[$i++]
218    };
219}
220
2211;
222
223__END__
224
225=head1 NAME
226
227CPAN::Queue - internal queue support for CPAN.pm
228
229=head1 LICENSE
230
231This program is free software; you can redistribute it and/or
232modify it under the same terms as Perl itself.
233
234=cut
235